Compare commits

..

No commits in common. "master" and "add_budget_limits" have entirely different histories.

12 changed files with 1686 additions and 2912 deletions

View File

@ -2,21 +2,21 @@
module Main (main) where module Main (main) where
import Control.Concurrent
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger import Control.Monad.Logger
import Data.Bitraversable import Control.Monad.Reader
-- import Data.Hashable
import qualified Data.Text.IO as TI import qualified Data.Text.IO as TI
import qualified Database.Esqueleto.Experimental as E import Database.Persist.Monad
import qualified Dhall hiding (double, record) import Dhall hiding (double, record)
import Internal.Budget
import Internal.Database import Internal.Database
import Internal.History
import Internal.Types.Main import Internal.Types.Main
import Internal.Utils import Internal.Utils
import Options.Applicative import Options.Applicative
import RIO import RIO
import RIO.FilePath import RIO.FilePath
-- import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
main :: IO () main :: IO ()
@ -30,26 +30,14 @@ main = parse =<< execParser o
<> header "pwncash - your budget, your life" <> header "pwncash - your budget, your life"
) )
type ConfigPath = FilePath data Options = Options FilePath Mode
type BudgetPath = FilePath
type HistoryPath = FilePath
data Options = Options !ConfigPath !Mode
data Mode data Mode
= Reset = Reset
| DumpCurrencies | DumpCurrencies
| DumpAccounts | DumpAccounts
| DumpAccountKeys | DumpAccountKeys
| Sync !SyncOptions | Sync
data SyncOptions = SyncOptions
{ syncBudgets :: ![BudgetPath]
, syncHistories :: ![HistoryPath]
, syncThreads :: !Int
}
configFile :: Parser FilePath configFile :: Parser FilePath
configFile = configFile =
@ -67,7 +55,7 @@ options =
<|> getConf dumpCurrencies <|> getConf dumpCurrencies
<|> getConf dumpAccounts <|> getConf dumpAccounts
<|> getConf dumpAccountKeys <|> getConf dumpAccountKeys
<|> getConf sync_ <|> getConf sync
where where
getConf m = Options <$> configFile <*> m getConf m = Options <$> configFile <*> m
@ -108,43 +96,14 @@ dumpAccountKeys =
<> help "Dump all account keys/aliases" <> help "Dump all account keys/aliases"
) )
sync_ :: Parser Mode sync :: Parser Mode
sync_ = sync =
flag' flag'
Sync Sync
( long "sync" ( long "sync"
<> short 'S' <> short 'S'
<> help "Sync config to database" <> help "Sync config to database"
) )
<*> syncOptions
syncOptions :: Parser SyncOptions
syncOptions =
SyncOptions
<$> many
( strOption
( long "budget"
<> short 'b'
<> metavar "BUDGET"
<> help "path to a budget config"
)
)
<*> many
( strOption
( long "history"
<> short 'H'
<> metavar "HISTORY"
<> help "path to a history config"
)
)
<*> option
auto
( long "threads"
<> short 't'
<> metavar "THREADS"
<> value 1
<> help "number of threads for syncing"
)
parse :: Options -> IO () parse :: Options -> IO ()
parse (Options c Reset) = do parse (Options c Reset) = do
@ -153,8 +112,7 @@ parse (Options c Reset) = do
parse (Options c DumpAccounts) = runDumpAccounts c parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c parse (Options c DumpCurrencies) = runDumpCurrencies c
parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) = parse (Options c Sync) = runSync c
runSync syncThreads c syncBudgets syncHistories
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m () runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
runDumpCurrencies c = do runDumpCurrencies c = do
@ -192,34 +150,50 @@ runDumpAccountKeys c = do
ar <- accounts <$> readConfig c ar <- accounts <$> readConfig c
let ks = let ks =
paths2IDs $ paths2IDs $
fmap (double . accountRFullpath . E.entityVal) $ fmap (double . fst) $
fst $ concatMap (t3 . uncurry tree2Records) $
indexAcntRoot ar flattenAcntRoot ar
mapM_ (uncurry printPair) ks mapM_ (uncurry printPair) ks
where where
printPair i p = do printPair i p = do
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i] liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
t3 (_, _, x) = x
double x = (x, x) double x = (x, x)
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO () runSync :: FilePath -> IO ()
runSync threads c bs hs = do runSync c = do
setNumCapabilities threads
config <- readConfig c config <- readConfig c
(bs', hs') <- let (hTs, hSs) = splitHistory $ statements config
fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs)
pool <- runNoLoggingT $ mkPool $ sqlConfig config pool <- runNoLoggingT $ mkPool $ sqlConfig config
setNumCapabilities 1 handle err $ do
handle err $ sync pool root config bs' hs' -- _ <- askLoggerIO
-- get the current DB state
(state, updates) <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ getDBState config
-- read desired statements from disk
bSs <-
flip runReaderT state $
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
-- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let hTransRes = mapErrors insertHistTransfer hTs
let bgtRes = mapErrors insertBudget $ budget config
updateDBState updates -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ do
mapM_ (uncurry insertHistStmt) bSs
combineError hTransRes bgtRes $ \_ _ -> ()
rerunnableIO $ fromEither res
where where
root = takeDirectory c root = takeDirectory c
err (AppException es) = do err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure exitFailure
readConfig :: MonadUnliftIO m => FilePath -> m Config -- showBalances
readConfig = fmap unfix . readDhall
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a readConfig :: MonadUnliftIO m => FilePath -> m Config
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath

View File

@ -75,8 +75,7 @@ library
ViewPatterns ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
build-depends: build-depends:
Decimal >=0.5.2 base >=4.12 && <10
, base >=4.12 && <10
, cassava , cassava
, conduit >=1.3.4.2 , conduit >=1.3.4.2
, containers >=0.6.4.1 , containers >=0.6.4.1
@ -145,8 +144,7 @@ executable pwncash
ViewPatterns ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
build-depends: build-depends:
Decimal >=0.5.2 base >=4.12 && <10
, base >=4.12 && <10
, budget , budget
, cassava , cassava
, conduit >=1.3.4.2 , conduit >=1.3.4.2

View File

@ -278,52 +278,9 @@ let DatePat =
-} -}
< Cron : CronPat.Type | Mod : ModPat.Type > < Cron : CronPat.Type | Mod : ModPat.Type >
let TxAmount1_ = let TxOpts =
\(re : Type) -> {- Additional metadata to use when parsing a statement -}
{ a1Column : Text { Type =
, a1Fmt :
{-
Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
re
}
let TxAmount1 =
{ Type = TxAmount1_ Text
, default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
}
let TxAmount2_ =
\(re : Type) ->
{ a2Positive : Text
, a2Negative : Text
, a2Fmt :
{-
Format of the amount field. Must include two fields for the
numerator and denominator of the amount.
-}
re
}
let TxAmount2 =
{ Type = TxAmount2_ Text
, default =
{ a2Positive = "Deposit"
, a2Negative = "Withdraw"
, a2Fmt = "([0-9\\.]+)"
}
}
let TxAmountSpec_ =
\(re : Type) ->
< AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
let TxOpts_ =
{-
Additional metadata to use when parsing a statement
-}
\(re : Type) ->
{ toDate : { toDate :
{- {-
Column title for date Column title for date
@ -333,7 +290,7 @@ let TxOpts_ =
{- {-
Column title for amount Column title for amount
-} -}
TxAmountSpec_ re Text
, toDesc : , toDesc :
{- {-
Column title for description Column title for description
@ -351,51 +308,19 @@ let TxOpts_ =
Data.Time.Format.formattime Haskell function. Data.Time.Format.formattime Haskell function.
-} -}
Text Text
, toSkipBlankDate : , toAmountFmt :
{- {- Format of the amount field. Must include three fields for the
Skip line if date field is a blank sign, numerator, and denominator of the amount.
-} -}
Bool Text
, toSkipBlankAmount :
{-
Skip line if amount field(s) is(are) a blank
-}
Bool
, toSkipBlankDescription :
{-
Skip line if description field is a blank
-}
Bool
, toSkipBlankOther :
{-
Skip line if any arbitrary fields are blank (these fields must also
be listed in 'toOther' to be considered)
-}
List Text
, toSkipMissingFields :
{-
Skip line if any fields are missing (this is different from blank;
'missing' means there is no field with name 'X', 'blank' means that
there is a field 'X' and its value is an empty string)
-}
Bool
} }
let TxAmountSpec = TxAmountSpec_ Text
let TxOpts =
{ Type = TxOpts_ Text
, default = , default =
{ toDate = "Date" { toDate = "Date"
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=} , toAmount = "Amount"
, toDesc = "Description" , toDesc = "Description"
, toOther = [] : List Text , toOther = [] : List Text
, toDateFmt = "%0m/%0d/%Y" , toDateFmt = "%0m/%0d/%Y"
, toSkipBlankDate = False , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
, toSkipBlankAmount = False
, toSkipBlankDescription = False
, toSkipBlankOther = [] : List Text
, toSkipMissingFields = False
} }
} }
@ -477,45 +402,9 @@ let EntryNumGetter =
LookupN: lookup the value from a field LookupN: lookup the value from a field
ConstN: a constant value ConstN: a constant value
AmountN: the value of the 'Amount' column times a scaling factor AmountN: the value of the 'Amount' column
BalanceN: the amount required to make the target account reach a balance
PercentN: the amount required to make an account reach a given percentage
-} -}
< LookupN : Text < LookupN : Text | ConstN : Double | AmountN : Double >
| ConstN : Double
| AmountN : Double
| BalanceN : Double
| PercentN : Double
>
let LinkedNumGetter =
{-
Means to get a numeric value from another entry
-}
{ Type =
{ lngIndex :
{-
Index of the entry to link.
-}
Natural
, lngScale :
{-
Factor by which to multiply the value of the linked entry.
-}
Double
}
, default = { lngScale = 1.0, lngIndex = 0 }
}
let LinkedEntryNumGetter =
{-
Means to get a numeric value from a statement row or another entry getter.
Linked: a number referring to the entry on the 'from' side of the
transaction (with 0 being the primary entry)
Getter: a normal getter
-}
< Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
let EntryTextGetter = let EntryTextGetter =
{- {-
@ -554,6 +443,7 @@ let Entry =
-} -}
\(a : Type) -> \(a : Type) ->
\(v : Type) -> \(v : Type) ->
\(c : Type) ->
\(t : Type) -> \(t : Type) ->
{ eAcnt : { eAcnt :
{- {-
@ -565,6 +455,11 @@ let Entry =
Pertains to value for this entry. Pertains to value for this entry.
-} -}
v v
, eCurrency :
{-
Pertains to value for this entry.
-}
c
, eComment : , eComment :
{- {-
A short description of this entry (if none, use a blank string) A short description of this entry (if none, use a blank string)
@ -579,107 +474,35 @@ let Entry =
let EntryGetter = let EntryGetter =
{- {-
Means for getting an entry from a given row in a statement (debit side) Means for getting an entry from a given row in a statement
-}
\(n : Type) ->
{ Type = Entry EntryAcntGetter n TagID
, default = { eComment = "", eTags = [] : List TagID }
}
let FromEntryGetter =
{-
Means for getting an entry from a given row in a statement (debit side)
-}
EntryGetter EntryNumGetter
let ToEntryGetter =
{-
Means for getting an entry from a given row in a statement (credit side)
-}
EntryGetter LinkedEntryNumGetter
let TxHalfGetter =
{-
Means of transforming one row in a statement to either the credit or debit
half of a transaction
-}
\(e : Type) ->
{ Type =
{ thgAcnt :
{-
Account from which this transaction will be balanced. The value
of the transaction will be assigned to this account unless
other entries are specified (see below).
This account (and its associated entry) will be denoted
'primary'.
-}
EntryAcntGetter
, thgEntries :
{-
Means of getting additional entries from which this transaction
will be balanced. If this list is empty, the total value of the
transaction will be assigned to the value defined by 'tsgAcnt'.
Otherwise, the entries specified here will be added to this side
of this transaction, and their sum value will be subtracted from
the total value of the transaction and assigned to 'tsgAcnt'.
This is useful for situations where a particular transaction
denotes values that come from multiple subaccounts.
-}
List e
, thgComment :
{-
Comment for the primary entry
-}
Text
, thgTags :
{-
Tags for the primary entry
-}
List TagID
}
, default =
{ thgTags = [] : List TagID
, thgComment = ""
, thgEntries = [] : List e
}
}
let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
let ToTxHalfGetter = TxHalfGetter ToEntryGetter.Type
let TxSubGetter =
{-
A means for transforming one row in a statement to a transaction
-} -}
{ Type = { Type =
{ tsgValue : EntryNumGetter Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
, tsgCurrency : EntryCurGetter , default = { eValue = None EntryNumGetter, eComment = "" }
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
}
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
} }
let TxGetter = let TxGetter =
{- {-
A means for transforming one row in a statement to a transaction A means for transforming one row in a statement to a transaction
Note that N-1 entries need to be specified to make a transaction, as the
Nth entry will be balanced with the others.
-} -}
{ Type = { tgEntries :
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type {-
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type A means of getting entries for this transaction (minimum 1)
, tgScale : Double -}
, tgCurrency : EntryCurGetter List EntryGetter.Type
, tgOtherEntries : List TxSubGetter.Type , tgCurrency :
} {-
, default = Currency against which entries in this transaction will be balanced
{ tgOtherEntries = [] : List TxSubGetter.Type -}
, tgFrom = TxHalfGetter EntryCurGetter
, tgTo = TxHalfGetter , tgAcnt :
, tgScale = 1.0 {-
} Account in which entries in this transaction will be balanced
-}
EntryAcntGetter
} }
let StatementParser_ = let StatementParser_ =
@ -719,7 +542,7 @@ let StatementParser_ =
a transaction. If none, don't make a transaction (eg 'skip' a transaction. If none, don't make a transaction (eg 'skip'
this row in the statement). this row in the statement).
-} -}
Optional TxGetter.Type Optional TxGetter
, spTimes : , spTimes :
{- {-
Match at most this many rows; if none there is no limit Match at most this many rows; if none there is no limit
@ -736,7 +559,7 @@ let StatementParser_ =
, spVal = ValMatcher::{=} , spVal = ValMatcher::{=}
, spDesc = None Text , spDesc = None Text
, spOther = [] : List (FieldMatcher_ re) , spOther = [] : List (FieldMatcher_ re)
, spTx = None TxGetter.Type , spTx = None TxGetter
, spTimes = None Natural , spTimes = None Natural
, spPriority = +0 , spPriority = +0
} }
@ -754,29 +577,7 @@ let Amount =
-} -}
\(w : Type) -> \(w : Type) ->
\(v : Type) -> \(v : Type) ->
{ Type = { amtWhen : w, amtValue : v, amtDesc : Text }
{ amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
, default.amtPriority = +0
}
let TransferType =
{-
The type of a budget transfer.
BTFixed: Tranfer a fixed amount
BTPercent: Transfer a percent of the source account to destination
BTTarget: Transfer an amount such that the destination has a given target
value
-}
< TPercent | TBalance | TFixed >
let TransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ Type = { tvVal : Double, tvType : TransferType }
, default.tvType = TransferType.TFixed
}
let Transfer = let Transfer =
{- {-
@ -789,24 +590,14 @@ let Transfer =
{ transFrom : a { transFrom : a
, transTo : a , transTo : a
, transCurrency : c , transCurrency : c
, transAmounts : List (Amount w v).Type , transAmounts : List (Amount w v)
}
let TaggedAcnt =
{-
An account with a tag
-}
{ Type = { taAcnt : AcntID, taTags : List TagID }
, default.taTags = [] : List TagID
} }
let HistTransfer = let HistTransfer =
{- {-
A manually specified historical transfer A manually specified historical transfer
-} -}
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type Transfer AcntID CurID DatePat Double
let TransferAmount = Amount DatePat TransferValue.Type
let Statement = let Statement =
{- {-
@ -843,6 +634,44 @@ let History =
-} -}
< HistTransfer : HistTransfer | HistStatement : Statement > < HistTransfer : HistTransfer | HistStatement : Statement >
let Exchange =
{-
A currency exchange.
-}
{ xFromCur :
{-
Starting currency of the exchange.
-}
CurID
, xToCur :
{-
Ending currency of the exchange.
-}
CurID
, xAcnt :
{-
account in which the exchange will be documented.
-}
AcntID
, xRate :
{-
The exchange rate between the currencies.
-}
Double
}
let BudgetCurrency =
{-
A 'currency' in the budget; either a fixed currency or an exchange
-}
< NoX : CurID | X : Exchange >
let TaggedAcnt =
{-
An account with a tag
-}
{ taAcnt : AcntID, taTags : List TagID }
let Allocation = let Allocation =
{- {-
How to allocate a given budget stream. This can be thought of as a Transfer How to allocate a given budget stream. This can be thought of as a Transfer
@ -850,7 +679,12 @@ let Allocation =
-} -}
\(w : Type) -> \(w : Type) ->
\(v : Type) -> \(v : Type) ->
{ alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type } { alloTo : TaggedAcnt
, alloAmts : List (Amount w v)
, alloCur :
{-TODO allow exchanges here-}
CurID
}
let PretaxValue = let PretaxValue =
{- {-
@ -945,8 +779,6 @@ let SingleAllocation =
-} -}
Allocation {} Allocation {}
let SingleAlloAmount = \(v : Type) -> Amount {} v
let MultiAllocation = let MultiAllocation =
{- {-
An allocation specialized to capturing multiple income streams within a given An allocation specialized to capturing multiple income streams within a given
@ -955,8 +787,6 @@ let MultiAllocation =
-} -}
Allocation Interval Allocation Interval
let MultiAlloAmount = \(v : Type) -> Amount Interval v
let HourlyPeriod = let HourlyPeriod =
{- {-
Definition for a pay period denominated in hours Definition for a pay period denominated in hours
@ -1039,40 +869,55 @@ let Income =
This must be an income AcntID, and is the only place income This must be an income AcntID, and is the only place income
accounts may be specified in the entire budget. accounts may be specified in the entire budget.
-} -}
TaggedAcnt.Type TaggedAcnt
, incToBal : , incToBal :
{- {-
The account to which to send the remainder of the income stream The account to which to send the remainder of the income stream
(if any) after all allocations have been applied. (if any) after all allocations have been applied.
-} -}
TaggedAcnt.Type TaggedAcnt
, incPriority : Integer
} }
, default = , default =
{ incPretax = [] : List (SingleAllocation PretaxValue) { incPretax = [] : List (SingleAllocation PretaxValue)
, incTaxes = [] : List (SingleAllocation TaxValue) , incTaxes = [] : List (SingleAllocation TaxValue)
, incPosttaxx = [] : List (SingleAllocation PosttaxValue) , incPosttaxx = [] : List (SingleAllocation PosttaxValue)
, incPriority = +0
} }
} }
let AcntMatcher_ = let AcntSet =
{- {-
Regex pattern by which matching account ids will be identified A list of account IDs represented as a set.
-} -}
\(re : Type) -> { Type =
{ Type = { amPat : re, amInvert : Bool }, default.amInvert = False } { asList : List AcntID
, asInclude :
{-
If true, tests for account membership in this set will return
true if the account is in the set. Invert this behavior otherwise.
-}
Bool
}
, default = { asList = [] : List AcntID, asInclude = False }
}
let AcntMatcher = AcntMatcher_ Text let TransferMatcher =
let TransferMatcher_ =
{- {-
Means to match a transfer (which will be used to "clone" it in some Means to match a transfer (which will be used to "clone" it in some
fashion) fashion)
-} -}
\(re : Type) -> { Type =
{ tmFrom : Optional (AcntMatcher_ re).Type { tmFrom :
, tmTo : Optional (AcntMatcher_ re).Type {-
List of accounts (which may be empty) to match with the
starting account in a transfer.
-}
AcntSet.Type
, tmTo :
{-
List of accounts (which may be empty) to match with the
ending account in a transfer.
-}
AcntSet.Type
, tmDate : , tmDate :
{- {-
If given, means to match the date of a transfer. If given, means to match the date of a transfer.
@ -1084,17 +929,25 @@ let TransferMatcher_ =
-} -}
ValMatcher.Type ValMatcher.Type
} }
let TransferMatcher =
{ Type = TransferMatcher_ Text
, default = , default =
{ tmFrom = None AcntMatcher.Type { tmFrom = AcntSet.default
, tmTo = None AcntMatcher.Type , tmTo = AcntSet.default
, tmDate = None DateMatcher , tmDate = None DateMatcher
, tmVal = ValMatcher.default , tmVal = ValMatcher.default
} }
} }
let BudgetTransferType =
{-
The type of a budget transfer.
BTFixed: Tranfer a fixed amount
BTPercent: Transfer a percent of the source account to destination
BTTarget: Transfer an amount such that the destination has a given target
value
-}
< BTPercent | BTTarget | BTFixed >
let ShadowTransfer = let ShadowTransfer =
{- {-
A transaction analogous to another transfer with given properties. A transaction analogous to another transfer with given properties.
@ -1103,17 +956,17 @@ let ShadowTransfer =
{- {-
Source of this transfer Source of this transfer
-} -}
TaggedAcnt.Type TaggedAcnt
, stTo : , stTo :
{- {-
Destination of this transfer. Destination of this transfer.
-} -}
TaggedAcnt.Type TaggedAcnt
, stCurrency : , stCurrency :
{- {-
Currency of this transfer. Currency of this transfer.
-} -}
CurID BudgetCurrency
, stDesc : , stDesc :
{- {-
Description of this transfer. Description of this transfer.
@ -1127,6 +980,7 @@ let ShadowTransfer =
specified in other fields of this type. specified in other fields of this type.
-} -}
TransferMatcher.Type TransferMatcher.Type
, stType : BudgetTransferType
, stRatio : , stRatio :
{- {-
Fixed multipler to translate value of matched transfer to this one. Fixed multipler to translate value of matched transfer to this one.
@ -1134,11 +988,17 @@ let ShadowTransfer =
Double Double
} }
let BudgetTransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ btVal : Double, btType : BudgetTransferType }
let BudgetTransfer = let BudgetTransfer =
{- {-
A manually specified transaction for a budget A manually specified transaction for a budget
-} -}
HistTransfer Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
let Budget = let Budget =
{- {-
@ -1180,7 +1040,6 @@ in { CurID
, CronPat , CronPat
, DatePat , DatePat
, TxOpts , TxOpts
, TxOpts_
, StatementParser , StatementParser
, StatementParser_ , StatementParser_
, ValMatcher , ValMatcher
@ -1189,13 +1048,10 @@ in { CurID
, FieldMatcher , FieldMatcher
, FieldMatcher_ , FieldMatcher_
, EntryNumGetter , EntryNumGetter
, LinkedEntryNumGetter
, LinkedNumGetter
, Field , Field
, FieldMap , FieldMap
, Entry , Entry
, FromEntryGetter , EntryGetter
, ToEntryGetter
, EntryTextGetter , EntryTextGetter
, EntryCurGetter , EntryCurGetter
, EntryAcntGetter , EntryAcntGetter
@ -1206,11 +1062,12 @@ in { CurID
, Budget , Budget
, Allocation , Allocation
, Amount , Amount
, TransferMatcher_
, TransferMatcher , TransferMatcher
, ShadowTransfer , ShadowTransfer
, AcntSet
, BudgetCurrency
, Exchange
, TaggedAcnt , TaggedAcnt
, AccountTree
, Account , Account
, Placeholder , Placeholder
, PretaxValue , PretaxValue
@ -1219,29 +1076,13 @@ in { CurID
, TaxProgression , TaxProgression
, TaxMethod , TaxMethod
, TaxValue , TaxValue
, TransferValue , BudgetTransferValue
, TransferType , BudgetTransferType
, TxGetter , TxGetter
, TxSubGetter
, TxHalfGetter
, FromTxHalfGetter
, ToTxHalfGetter
, HistTransfer , HistTransfer
, SingleAllocation , SingleAllocation
, MultiAllocation , MultiAllocation
, HourlyPeriod , HourlyPeriod
, Period , Period
, PeriodType , PeriodType
, TransferAmount
, MultiAlloAmount
, SingleAlloAmount
, AcntMatcher_
, AcntMatcher
, TxAmountSpec
, TxAmountSpec_
, TxAmount1_
, TxAmount2_
, TxAmount1
, TxAmount2
, BudgetTransfer
} }

View File

@ -4,10 +4,18 @@ let List/map =
let T = ./Types.dhall let T = ./Types.dhall
let nullEntry = let nullSplit =
\(a : T.EntryAcntGetter) -> \(a : T.EntryAcntGetter) ->
\(v : T.EntryNumGetter) -> \(c : T.EntryCurGetter) ->
T.FromEntryGetter::{ eAcnt = a, eValue = v } T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
let nullOpts = T.TxOpts::{=}
let nullVal = T.ValMatcher::{=}
let nullMatch = T.StatementParser::{=}
let nullCron = T.CronPat::{=}
let nullMod = let nullMod =
\(by : Natural) -> \(by : Natural) ->
@ -19,22 +27,21 @@ let cron1 =
\(m : Natural) -> \(m : Natural) ->
\(d : Natural) -> \(d : Natural) ->
T.DatePat.Cron T.DatePat.Cron
T.CronPat::{ ( nullCron
, cpYear = Some (T.MDYPat.Single y) // { cpYear = Some (T.MDYPat.Single y)
, cpMonth = Some (T.MDYPat.Single m) , cpMonth = Some (T.MDYPat.Single m)
, cpDay = Some (T.MDYPat.Single d) , cpDay = Some (T.MDYPat.Single d)
} }
)
let matchInf_ = T.StatementParser::{=} let matchInf_ = nullMatch
let matchInf = \(x : T.TxGetter.Type) -> T.StatementParser::{ spTx = Some x } let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
let matchN_ = \(n : Natural) -> T.StatementParser::{ spTimes = Some n } let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
let matchN = let matchN =
\(n : Natural) -> \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
\(x : T.TxGetter.Type) ->
matchInf x // { spTimes = Some n }
let match1_ = matchN_ 1 let match1_ = matchN_ 1
@ -79,45 +86,46 @@ let mRngYMD =
\(r : Natural) -> \(r : Natural) ->
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r } T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text } let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
let partNFrom = let partN =
\(ss : List PartEntry) -> \(c : T.EntryCurGetter) ->
let toEntry = \(a : T.EntryAcntGetter) ->
\(x : PartEntry) -> \(comment : Text) ->
T.FromEntryGetter::{ \(ss : List PartSplit) ->
, eAcnt = T.EntryAcntGetter.ConstT x._1 let toSplit =
, eValue = T.EntryNumGetter.ConstN x._2 \(x : PartSplit) ->
nullSplit (T.EntryAcntGetter.ConstT x._1) c
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
, eComment = x._3 , eComment = x._3
} }
in List/map PartEntry T.FromEntryGetter.Type toEntry ss in [ nullSplit a c // { eComment = comment } ]
# List/map PartSplit T.EntryGetter.Type toSplit ss
let partNTo = let part1 =
\(ss : List PartEntry) -> \(c : T.EntryCurGetter) ->
let toEntry = \(a : T.EntryAcntGetter) ->
\(x : PartEntry) -> \(comment : Text) ->
T.ToEntryGetter::{ partN c a comment ([] : List PartSplit)
, eAcnt = T.EntryAcntGetter.ConstT x._1
, eValue =
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
in List/map PartEntry T.ToEntryGetter.Type toEntry ss let part1_ =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
partN c a "" ([] : List PartSplit)
let addDay = let addDay =
\(x : T.GregorianM) -> \(x : T.GregorianM) ->
\(d : Natural) -> \(d : Natural) ->
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d } { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
let mvP = T.ValMatcher::{ vmSign = Some True } let mvP = nullVal // { vmSign = Some True }
let mvN = T.ValMatcher::{ vmSign = Some False } let mvN = nullVal // { vmSign = Some False }
let mvNum = \(x : Natural) -> T.ValMatcher::{ vmNum = Some x } let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
let mvDen = \(x : Natural) -> T.ValMatcher::{ vmDen = Some x } let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x } let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
@ -127,7 +135,13 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x } let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
in { cron1 in { nullSplit
, nullMatch
, nullVal
, nullOpts
, nullCron
, nullMod
, cron1
, mY , mY
, mYM , mYM
, mYMD , mYMD
@ -142,8 +156,9 @@ in { cron1
, match1 , match1
, greg , greg
, gregM , gregM
, partNFrom , partN
, partNTo , part1
, part1_
, addDay , addDay
, comma = 44 , comma = 44
, tab = 9 , tab = 9
@ -155,8 +170,6 @@ in { cron1
, mvDen , mvDen
, mvDenP , mvDenP
, mvDenN , mvDenN
, PartEntry , PartSplit
, nullEntry
, nullMod
} }
/\ T /\ T

View File

@ -1,9 +1,9 @@
module Internal.Budget (readBudgetCRUD) where module Internal.Budget (insertBudget) where
import Control.Monad.Except import Control.Monad.Except
import Data.Decimal hiding (allocate)
import Data.Foldable import Data.Foldable
import Data.Hashable import Database.Persist.Monad
import Internal.Database
import Internal.Types.Main import Internal.Types.Main
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
@ -13,13 +13,22 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD -- each budget (designated at the top level by a 'name') is processed in the
readBudgetCRUD o@CRUDOps {coCreate} = do -- following steps
bs <- mapM readBudget coCreate -- 1. expand all transactions given the desired date range and date patterns for
return $ o {coCreate = bs} -- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions
-- 5. insert all transactions
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR]) insertBudget
readBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m ()
insertBudget
b@Budget b@Budget
{ bgtLabel { bgtLabel
, bgtIncomes , bgtIncomes
@ -30,18 +39,15 @@ readBudget
, bgtPosttax , bgtPosttax
, bgtInterval , bgtInterval
} = } =
do whenHash CTBudget b () $ \key -> do
spanRes <- getSpan
(bgtLabel,) <$> case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,) (intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers c budgetSpan bgtTransfers let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
combineErrorM (concat <$> res1) res2 $ \is ts -> txs <- combineError (concat <$> res1) res2 (++)
addShadowTransfers bgtShadowTransfers (is ++ ts) m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
where where
c = CommitR (CommitHash $ hash b) CTBudget
acntRes = mapErrors isNotIncomeAcnt alloAcnts acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,) intAlloRes = combineError3 pre_ tax_ post_ (,,)
pre_ = sortAllos bgtPretax pre_ = sortAllos bgtPretax
@ -52,15 +58,73 @@ readBudget
(alloAcnt <$> bgtPretax) (alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax) ++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- asks (unBSpan . tsBudgetScope)
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan
sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v) balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
let balTo = M.findWithDefault 0 ftTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
in (bals', f {ftValue = x})
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer
-> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k entry = do
sk <- insertEntry k entry
insert_ $ BudgetLabelR sk $ bmName ftMeta
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (EntryPair, Maybe EntryPair)
entryPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = entry curid from_ (-v)
let s2 = entry curid to_ v
combineError s1 s2 (,)
entry c TaggedAcnt {taAcnt, taTags} v =
resolveEntry $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs} return $ a {alloAmts = reverse bs}
@ -79,101 +143,100 @@ sortAllo a@Allocation {alloAmts = as} = do
-- TODO this will scan the interval allocations fully each time -- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this -- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :( -- loop into a fold which I don't feel like doing now :(
readIncome insertIncome
:: (MonadAppError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> CommitR => CommitRId
-> T.Text
-> IntAllocations -> IntAllocations
-> DaySpan -> Maybe Interval
-> Income -> Income
-> m [Tx CommitR] -> m [UnbalancedTransfer]
readIncome insertIncome
key key
name
(intPre, intTax, intPost) (intPre, intTax, intPost)
ds localInterval
Income Income
{ incWhen { incWhen
, incCurrency , incCurrency
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags} , incFrom
, incPretax , incPretax
, incPosttax , incPosttax
, incTaxes , incTaxes
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags} , incToBal
, incGross , incGross
, incPayPeriod , incPayPeriod
, incPriority
} = } =
combineErrorM combineErrorM
(combineError incRes nonIncRes (,)) (combineError incRes nonIncRes (,))
(combineError cpRes dayRes (,)) (combineError precRes dayRes (,))
$ \_ (cp, days) -> do $ \_ (precision, days) -> do
let gross = realFracToDecimalP (cpPrec cp) incGross let gross = roundPrecision precision incGross
foldDays (allocate cp gross) start days concat <$> foldDays (allocate precision gross) start days
where where
srcAcnt' = AcntID srcAcnt incRes = isIncomeAcnt $ taAcnt incFrom
destAcnt' = AcntID destAcnt
incRes = isIncomeAcnt srcAcnt'
nonIncRes = nonIncRes =
mapErrors isNotIncomeAcnt $ mapErrors isNotIncomeAcnt $
destAcnt' taAcnt incToBal
: (alloAcnt <$> incPretax) : (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes) ++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax) ++ (alloAcnt <$> incPosttax)
cpRes = lookupCurrency incCurrency precRes = lookupCurrencyPrec incCurrency
dayRes = liftExcept $ expandDatePat ds incWhen dayRes = askDays incWhen localInterval
start = fromGregorian' $ pStart incPayPeriod start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod pType' = pType incPayPeriod
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue sumAllos = sum . fmap faValue
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts} -- TODO ensure these are all the "correct" accounts
allocate cp gross prevDay day = do allocate precision gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day scaler <- liftExcept $ periodScaler pType' prevDay day
let precision = cpPrec cp
let (preDeductions, pre) = let (preDeductions, pre) =
allocatePre precision gross $ allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre flatPre ++ concatMap (selectAllos day) intPre
let tax = tax =
allocateTax precision gross preDeductions scaler $ allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre) aftertaxGross = gross - sumAllos (tax ++ pre)
let post = post =
allocatePost precision aftertaxGross $ allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost flatPost ++ concatMap (selectAllos day) intPost
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags) balance = aftertaxGross - sumAllos post
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags) bal =
let allos = allo2Trans <$> (pre ++ tax ++ post) FlatTransfer
let primary = { ftMeta = meta
EntrySet , ftWhen = day
{ esTotalValue = -gross , ftFrom = incFrom
, esCurrency = cpID cp , ftCur = NoX incCurrency
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []} , ftTo = incToBal
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos} , ftValue = UnbalancedValue BTFixed balance
} , ftDesc = "balance after deductions"
return $
Tx
{ txMeta = TxMeta day incPriority (TxDesc "") key
, txPrimary = Left primary
, txOther = []
} }
in if balance < 0
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
periodScaler periodScaler
:: PeriodType :: PeriodType
-> Day -> Day
-> Day -> Day
-> AppExcept PeriodScaler -> InsertExcept PeriodScaler
periodScaler pt prev cur = return scale periodScaler pt prev cur = return scale
where where
n = workingDays wds prev cur n = fromIntegral $ workingDays wds prev cur
wds = case pt of wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds Daily ds -> ds
scale prec x = case pt of scale precision x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} -> Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
realFracToDecimalP prec (x / fromIntegral hpAnnualHours) fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours * fromIntegral hpDailyHours
* fromIntegral n * n
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25) Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
-- ASSUME start < end -- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural workingDays :: [Weekday] -> Day -> Day -> Natural
@ -189,7 +252,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
-- ASSUME days is a sorted list -- ASSUME days is a sorted list
foldDays foldDays
:: MonadAppError m :: MonadInsertError m
=> (Day -> Day -> m a) => (Day -> Day -> m a)
-> Day -> Day
-> [Day] -> [Day]
@ -199,27 +262,27 @@ foldDays f start days = case NE.nonEmpty days of
Just ds Just ds
| any (start >) ds -> | any (start >) ds ->
throwError $ throwError $
AppException [PeriodError start $ minimum ds] InsertException [PeriodError start $ minimum ds]
| otherwise -> | otherwise ->
combineErrors $ combineErrors $
snd $ snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m () isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt = checkAcntType IncomeT isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m () isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT]) isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
checkAcntType checkAcntType
:: (MonadAppError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> AcntType => AcntType
-> AcntID -> AcntID
-> m () -> m ()
checkAcntType t = checkAcntTypes (t :| []) checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes checkAcntTypes
:: (MonadAppError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType => NE.NonEmpty AcntType
-> AcntID -> AcntID
-> m () -> m ()
@ -227,70 +290,83 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
where where
go t go t
| t `L.elem` ts = return i | t `L.elem` ts = return i
| otherwise = throwError $ AppException [AccountTypeError i ts] | otherwise = throwError $ InsertException [AccountError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v] flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where where
go Amount {amtValue, amtDesc} = go Amount {amtValue, amtDesc} =
FlatAllocation FlatAllocation
{ faTo = alloTo { faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue , faValue = amtValue
, faDesc = amtDesc , faDesc = amtDesc
} }
-- ASSUME allocations are sorted -- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v] selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloTo} = selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where where
go Amount {amtValue, amtDesc} = go Amount {amtValue, amtDesc} =
FlatAllocation FlatAllocation
{ faTo = alloTo { faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue , faValue = amtValue
, faDesc = amtDesc , faDesc = amtDesc
} }
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID allo2Trans
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} = :: BudgetMeta
Entry -> Day
{ eValue = LinkValue (EntryFixed faValue) -> TaggedAcnt
, eComment = faDesc -> FlatAllocation Rational
, eAcnt = AcntID taAcnt -> UnbalancedTransfer
, eTags = TagID <$> taTags allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = from
, ftCur = faCur
, ftTo = faTo
, ftValue = UnbalancedValue BTFixed faValue
, ftDesc = faDesc
} }
type PreDeductions = M.Map T.Text Decimal
allocatePre allocatePre
:: Precision :: Natural
-> Decimal -> Rational
-> [FlatAllocation PretaxValue] -> [FlatAllocation PretaxValue]
-> (PreDeductions, [FlatAllocation Decimal]) -> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty allocatePre precision gross = L.mapAccumR go M.empty
where where
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} = go m f@FlatAllocation {faValue} =
let v = let c = preCategory faValue
if prePercent p = preValue faValue
then gross *. (preValue / 100) v =
else realFracToDecimalP precision preValue if prePercent faValue
in (mapAdd_ preCategory v m, f {faValue = v}) then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
allocateTax allocateTax
:: Precision :: Natural
-> Decimal -> Rational
-> PreDeductions -> M.Map T.Text Rational
-> PeriodScaler -> PeriodScaler
-> [FlatAllocation TaxValue] -> [FlatAllocation TaxValue]
-> [FlatAllocation Decimal] -> [FlatAllocation Rational]
allocateTax precision gross preDeds f = fmap (fmap go) allocateTax precision gross preDeds f = fmap (fmap go)
where where
go TaxValue {tvCategories, tvMethod} = go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories) let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of in case tvMethod of
TMPercent p -> agi *. p / 100 TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} -> TMBracket TaxProgression {tpDeductible, tpBrackets} ->
let taxDed = f precision tpDeductible let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets in foldBracket f precision (agi - taxDed) tpBrackets
-- | Compute effective tax percentage of a bracket -- | Compute effective tax percentage of a bracket
@ -304,102 +380,174 @@ allocateTax precision gross preDeds f = fmap (fmap go)
-- --
-- In reality, this can all be done with one loop, but it isn't clear these -- In reality, this can all be done with one loop, but it isn't clear these
-- three steps are implemented from this alone. -- three steps are implemented from this alone.
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where where
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) = go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
let l = f prec tbLowerLimit let l = roundPrecision precision $ f precision tbLowerLimit
in if remain >= l p = roundPrecision 3 tbPercent / 100
then (acc + (remain - l) *. (tbPercent / 100), l) in if remain >= l then (acc + p * (remain - l), l) else a
else a
allocatePost allocatePost
:: Precision :: Natural
-> Decimal -> Rational
-> [FlatAllocation PosttaxValue] -> [FlatAllocation PosttaxValue]
-> [FlatAllocation Decimal] -> [FlatAllocation Rational]
allocatePost prec aftertax = fmap (fmap go) allocatePost precision aftertax = fmap (fmap go)
where where
go PosttaxValue {postValue, postPercent} go PosttaxValue {postValue, postPercent} =
| postPercent = aftertax *. (postValue / 100) let v = postValue
| otherwise = realFracToDecimalP prec postValue in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
--------------------------------------------------------------------------------
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [UnbalancedTransfer]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn ftWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
-> m [UnbalancedTransfer]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftCur = transCurrency
, ftFrom = transFrom
, ftTo = transTo
, ftValue = UnbalancedValue y $ roundPrecision precision v
, ftDesc = desc
}
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- shadow transfers -- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem? -- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers addShadowTransfers
:: (MonadAppError m, MonadFinance m) :: CurrencyMap
=> [ShadowTransfer] -> [ShadowTransfer]
-> [Tx CommitR] -> [UnbalancedTransfer]
-> m [Tx CommitR] -> InsertExcept [UnbalancedTransfer]
addShadowTransfers ms = mapErrors go addShadowTransfers cm ms txs =
where fmap catMaybes $
go tx = do combineErrors $
es <- catMaybes <$> mapErrors (fromShadow tx) ms fmap (uncurry (fromShadow cm)) $
return $ tx {txOther = Right <$> es} [(t, m) | t <- txs, m <- ms]
fromShadow fromShadow
:: (MonadAppError m, MonadFinance m) :: CurrencyMap
=> Tx CommitR -> UnbalancedTransfer
-> ShadowTransfer -> ShadowTransfer
-> m (Maybe ShadowEntrySet) -> InsertExcept (Maybe UnbalancedTransfer)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
combineErrorM curRes mRes $ \cur compiled -> do res <- shadowMatches (stMatch t) tx
res <- liftExcept $ shadowMatches compiled tx v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not res then Nothing else Just es
where
curRes = lookupCurrencyKey stCurrency
mRes = liftExcept $ compileMatch stMatch
shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
shadowMatches
TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
Tx {txPrimary, txMeta = TxMeta {txmDate}} =
do
-- ASSUME these will never fail and thus I don't need to worry about
-- stacking the errors
fromRes <- acntMatches fa tmFrom
toRes <- acntMatches ta tmTo
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $ return $
fromRes if not res
&& toRes then Nothing
&& maybe True (`dateMatches` txmDate) tmDate else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
&& valRes && valRes
where where
fa = either getAcntFrom getAcntFrom txPrimary memberMaybe x AcntSet {asList, asInclude} =
ta = either getAcntTo getAcntTo txPrimary (if asInclude then id else not) $ x `elem` asList
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
acntMatches (AcntID a) = maybe (return True) (match' a)
match' a AcntMatcher_ {amPat, amInvert} =
(if amInvert then not else id) <$> matchMaybe a amPat
compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
where
go a@AcntMatcher_ {amPat} = do
(_, p) <- compileRegex False amPat
return $ a {amPat = p}
tres = mapM go tmTo
fres = mapM go tmFrom
-- memberMaybe x AcntSet {asList, asInclude} =
-- (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- random -- random
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID alloAcnt :: Allocation w v -> AcntID
alloAcnt = AcntID . taAcnt . alloTo alloAcnt = taAcnt . alloTo
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
type IntAllocations = type IntAllocations =
( [DaySpanAllocation PretaxValue] ( [DaySpanAllocation PretaxValue]
@ -409,11 +557,14 @@ type IntAllocations =
type DaySpanAllocation = Allocation DaySpan type DaySpanAllocation = Allocation DaySpan
type PeriodScaler = Precision -> Double -> Decimal type EntryPair = (KeyEntry, KeyEntry)
type PeriodScaler = Natural -> Double -> Double
data FlatAllocation v = FlatAllocation data FlatAllocation v = FlatAllocation
{ faValue :: !v { faValue :: !v
, faDesc :: !T.Text , faDesc :: !T.Text
, faTo :: !TaggedAcnt , faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
} }
deriving (Functor, Show) deriving (Functor, Show)

File diff suppressed because it is too large Load Diff

View File

@ -1,17 +1,15 @@
module Internal.History module Internal.History
( readHistStmt ( splitHistory
, readHistTransfer , insertHistTransfer
, splitHistory , readHistStmt
, readHistoryCRUD , insertHistStmt
) )
where where
import Control.Monad.Except import Control.Monad.Except
import Data.Csv import Data.Csv
import Data.Decimal import Database.Persist.Monad
import Data.Foldable import Internal.Database
import Data.Hashable
import GHC.Real
import Internal.Types.Main import Internal.Types.Main
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
@ -22,73 +20,107 @@ import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
import qualified RIO.Vector as V import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
readHistoryCRUD splitHistory :: [History] -> ([HistTransfer], [Statement])
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> PreHistoryCRUD
-> m FinalHistoryCRUD
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
-- TODO multithread this for some extra fun :)
ss' <- mapErrorsIO (readHistStmt root) ss
fromEitherM $ runExceptT $ do
let sRes = mapErrors (ExceptT . return) ss'
let tRes = mapErrors readHistTransfer ts
combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
-- NOTE keep statement and transfer readers separate because the former needs
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
-- thingy
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory = partitionEithers . fmap go splitHistory = partitionEithers . fmap go
where where
go (HistTransfer x) = Left x go (HistTransfer x) = Left x
go (HistStatement x) = Right x go (HistStatement x) = Right x
-------------------------------------------------------------------------------- insertHistTransfer
-- Transfers :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
readHistTransfer -> m ()
:: (MonadAppError m, MonadFinance m) insertHistTransfer
=> PairedTransfer m@Transfer
-> m [Tx CommitR] { transFrom = from
readHistTransfer ht = do , transTo = to
bounds <- asks (unHSpan . tsHistoryScope) , transCurrency = u
expandTransfer c bounds ht , transAmounts = amts
where } = do
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
-------------------------------------------------------------------------------- let precRes = lookupCurrencyPrec u
-- Statements let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
readHistStmt readHistStmt
:: (MonadUnliftIO m, MonadFinance m) :: (MonadUnliftIO m, MonadFinance m)
=> FilePath => FilePath
-> Statement -> Statement
-> m (Either AppException [Tx CommitR]) -> m (Maybe (CommitR, [KeyTx]))
readHistStmt root i = do readHistStmt root i = whenHash_ CTImport i $ do
bounds <- asks (unHSpan . tsHistoryScope)
bs <- readImport root i bs <- readImport root i
return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where where
go t@Tx {txMeta = m} = split a v =
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}} Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txEntries = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txEntries = ss} =
fmap (\kss -> t {txEntries = kss}) $
combineErrors $
fmap resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
--------------------------------------------------------------------------------
-- Statements
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Either AppException [Tx ()])
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,) (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt paths records <- L.sort . concat <$> mapErrorsIO readStmt paths
runExceptT (matchRecords compiledMatches records) m <- askDBState kmCurrency
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
where where
paths = (root </>) <$> stmtPaths paths = (root </>) <$> stmtPaths
@ -101,9 +133,9 @@ readImport_
-> m [TxRecord] -> m [TxRecord]
readImport_ n delim tns p = do readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p res <- tryIO $ BL.readFile p
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> throwIO $ AppException [ParseError $ T.pack m] Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v Right (_, v) -> return $ catMaybes $ V.toList v
where where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim} opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@ -112,93 +144,39 @@ readImport_ n delim tns p = do
-- TODO handle this better, this maybe thing is a hack to skip lines with -- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible -- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord) parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
p d <- r .: T.encodeUtf8 toDate
TxOpts if d == ""
{ toDate
, toDesc
, toAmount
, toOther
, toDateFmt
, toSkipBlankDate
, toSkipBlankAmount
, toSkipBlankDescription
, toSkipBlankOther
, toSkipMissingFields
}
r =
do
-- TODO this is confusing as hell
--
-- try and parse all fields; if a parse fails, either trip an error
-- or return a Nothing if we want to deliberately skip missing fields
d <- getField toDate
e <- getField toDesc
os <-
fmap M.fromList . sequence
<$> mapM (\n -> fmap (n,) <$> getField n) toOther
(af, ax) <- case toAmount of
-- the amount column is extra confusing because it can either be one
-- or two columns, so keep track of this with a maybe
AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
f <- getField a1Column
return (a1Fmt, Right <$> f)
AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
f1 <- getField a2Positive
f2 <- getField a2Negative
return $ (a2Fmt,) $ case (f1, f2) of
(Just a, Just b) -> Just $ Left (a, b)
_ -> Nothing
case (d, e, os, ax) of
-- If all lookups were successful, check that none of the fields are
-- blank, and if they are return nothing to skip this line
(Just d', Just e', Just os', Just ax') ->
if (toSkipBlankDate && d' == "")
|| (toSkipBlankDescription && e' == "")
|| (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
|| elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
then return Nothing then return Nothing
else -- if we are skipping nothing, proceed to parse the date and amount else do
-- columns a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
do e <- r .: T.encodeUtf8 toDesc
a <- case ax' of os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
Right a -> parseDecimal True af a d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
Left ("", a) -> ((-1) *) <$> parseDecimal False af a return $ Just $ TxRecord d' a e os p
Left (a, _) -> parseDecimal False af a
d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
return $ Just $ TxRecord d'' a e' os' p
-- if no lookups succeeded, return nothing to skip this line. Note that
-- a parse fail will trigger a failure error further up, so that case
-- is already dealt with implicitly
_ -> return Nothing
where
getField :: FromField a => T.Text -> Parser (Maybe a)
getField f = case runParser $ r .: T.encodeUtf8 f of
Left err -> if toSkipMissingFields then return Nothing else fail err
Right x -> return $ Just x
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()] matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords ms rs = do matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_ (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ AppException [StatementError us ns] (_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [StatementParserRe] -> [MatchGroup] matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities = matchPriorities =
fmap matchToGroup fmap matchToGroup
. L.groupBy (\a b -> spPriority a == spPriority b) . L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority) . L.sortOn (Down . spPriority)
matchToGroup :: [StatementParserRe] -> MatchGroup matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms = matchToGroup ms =
uncurry MatchGroup $ uncurry MatchGroup $
first (L.sortOn spDate) $ first (L.sortOn spDate) $
L.partition (isJust . spDate) ms L.partition (isJust . spDate) ms
data MatchGroup = MatchGroup data MatchGroup = MatchGroup
{ mgDate :: ![StatementParserRe] { mgDate :: ![MatchRe]
, mgNoDate :: ![StatementParserRe] , mgNoDate :: ![MatchRe]
} }
deriving (Show) deriving (Show)
@ -236,10 +214,9 @@ zipperSlice f x = go
LT -> z LT -> z
zipperMatch zipperMatch
:: MonadFinance m :: Unzipped MatchRe
=> Unzipped StatementParserRe
-> TxRecord -> TxRecord
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ())) -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail) go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -253,10 +230,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass) in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch' zipperMatch'
:: MonadFinance m :: Zipped MatchRe
=> Zipped StatementParserRe
-> TxRecord -> TxRecord
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ())) -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = do go (Zipped bs (a : as)) = do
@ -267,17 +243,13 @@ zipperMatch' z x = go z
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail) go z' = return (z', MatchFail)
matchDec :: StatementParserRe -> Maybe StatementParserRe matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of matchDec m = case spTimes m of
Just 1 -> Nothing Just 1 -> Nothing
Just n -> Just $ m {spTimes = Just $ n - 1} Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m Nothing -> Just m
matchAll matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
@ -287,21 +259,13 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs (ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
:: MonadFinance m
=> MatchGroup
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs (md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest (mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
matchDates matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
:: MonadFinance m
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchDates ms = go ([], [], initZipper ms) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -322,11 +286,7 @@ matchDates ms = go ([], [], initZipper ms)
go (m, u, z') rs go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
:: MonadFinance m
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchNonDates ms = go ([], [], initZipper ms) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -343,225 +303,26 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched) MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs in go (m, u, resetZipper z') rs
matches balanceTx :: RawTx -> InsertExcept BalTx
:: MonadFinance m balanceTx t@Tx {txEntries = ss} = do
=> StatementParserRe bs <- balanceEntries ss
-> TxRecord return $ t {txEntries = bs}
-> AppExceptT m (MatchRes (Tx ()))
matches balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority} balanceEntries ss =
r@TxRecord {trDate, trAmount, trDesc, trOther} = do fmap concat
res <- liftInner $ <$> mapM (uncurry bal)
combineError3 val other desc $ $ groupByKey
\x y z -> x && y && z && date $ fmap (\s -> (eCurrency s, s)) ss
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
where where
val = valMatches spVal $ toRational trAmount haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
date = maybe True (`dateMatches` trDate) spDate haeValue s = Left s
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther bal cur rss
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r | otherwise = case partitionEithers $ fmap haeValue rss of
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ()) groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
toTx groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
priority
TxGetter
{ tgFrom
, tgTo
, tgCurrency
, tgOtherEntries
, tgScale
}
r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ txMeta = TxMeta trDate priority trDesc ()
, txPrimary =
Left $
EntrySet
{ esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
, txOther = Left <$> ss
}
where
curRes = do
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tgCurrency
let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
resolveSubGetter
:: MonadFinance m
=> TxRecord
-> TxSubGetter
-> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency
let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
let valRes = liftInner $ resolveValue prec r tsgValue
liftInner $ combineErrorM toRes valRes $ \t v -> do
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
return $
EntrySet
{ esTotalValue = ()
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
resolveHalfEntry
:: (Precision -> TxRecord -> n -> AppExcept v')
-> Precision
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
-> AppExcept (HalfEntrySet v v')
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = v
, eComment = thgComment
, eTags = thgTags
}
, hesOther = es
}
where
acntRes = resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f prec r) thgEntries
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveEntry
:: (Precision -> TxRecord -> n -> AppExcept v)
-> Precision
-> TxRecord
-> EntryGetter n
-> AppExcept (Entry AcntID v TagID)
resolveEntry f prec r s@Entry {eAcnt, eValue} =
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
where
acntRes = resolveAcnt r eAcnt
valRes = f prec r eValue
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveFromValue = resolveValue
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveValue prec TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ EntryFixed $ go c
AmountN m -> return $ EntryFixed $ trAmount *. m
BalanceN x -> return $ EntryBalance $ go x
PercentN x -> return $ EntryPercent x
where
go = realFracToDecimalP prec
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
resolveCurrency m r c = do
i <- resolveEntryField CurField r (unCurID <$> c)
case M.lookup (CurID i) m of
Just k -> return k
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
ConstT p -> return p
LookupT f -> lookup_ f o
MapT (Field f m) -> do
k <- lookup_ f o
lookup_ k m
Map2T (Field (f1, f2) m) -> do
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
lookup_ = lookupErr (EntryIDField t)
readDouble :: T.Text -> AppExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> return x
Nothing -> throwError $ AppException [ConversionError s True]
readRational :: T.Text -> AppExcept Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
(Just x', Just y') ->
let p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
where
readT = readMaybe . T.unpack
err = throwError $ AppException [ConversionError s False]
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions = mapM (compileRegex True)
-- compileOptions o@TxOpts {toAmount = pat} = case pat of
-- AmountSingle (TxAmount1 {a1Fmt}) -> do
-- re <- compileRegex True a1Fmt
-- return $ o {toAmountFmt = re}
-- AmountDual (TxAmount2 {a2Fmt}) -> do
-- re <- compileRegex True a2Fmt
-- return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
go = compileRegex False
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
(True, [sign, num]) -> do
k <- readSign sign
x <- readNum num
return $ k * x
(False, [num]) -> readNum num
_ -> msg "malformed decimal"
where
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
T.unpack $
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
readSign x
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
readNum x =
maybe
(msg $ T.unwords ["could not parse", singleQuote x])
return
$ readMaybe
$ T.unpack
$ T.filter (/= ',') x

View File

@ -7,12 +7,9 @@
-- | Types corresponding to the database model -- | Types corresponding to the database model
module Internal.Types.Database where module Internal.Types.Database where
import Data.Csv (FromField)
import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH import Database.Persist.TH
import Internal.Types.Dhall
import RIO import RIO
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
@ -20,106 +17,51 @@ share
[mkPersist sqlSettings, mkMigrate "migrateAll"] [mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase| [persistLowerCase|
CommitR sql=commits CommitR sql=commits
hash CommitHash hash Int
type ConfigType type ConfigType
UniqueCommitHash hash deriving Show Eq
deriving Show Eq Ord
ConfigStateR sql=config_state
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
CurrencyR sql=currencies CurrencyR sql=currencies
symbol CurID symbol T.Text
fullname T.Text fullname T.Text
precision Precision precision Int
UniqueCurrencySymbol symbol deriving Show Eq
UniqueCurrencyFullname fullname
deriving Show Eq Ord
TagR sql=tags TagR sql=tags
symbol TagID symbol T.Text
fullname T.Text fullname T.Text
UniqueTagSymbol symbol deriving Show Eq
UniqueTagFullname fullname
deriving Show Eq Ord
AccountR sql=accounts AccountR sql=accounts
name T.Text name T.Text
fullpath AcntPath fullpath T.Text
desc T.Text desc T.Text
sign AcntSign deriving Show Eq
leaf Bool
UniqueAccountFullpath fullpath
deriving Show Eq Ord
AccountPathR sql=account_paths AccountPathR sql=account_paths
parent AccountRId parent AccountRId OnDeleteCascade
child AccountRId child AccountRId OnDeleteCascade
depth Int depth Int
deriving Show Eq Ord deriving Show Eq
TransactionR sql=transactions TransactionR sql=transactions
commit CommitRId commit CommitRId OnDeleteCascade
date Day date Day
budgetName BudgetName description T.Text
description TxDesc
priority Int
deriving Show Eq deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId
currency CurrencyRId
index EntrySetIndex
rebalance Bool
deriving Show Eq
EntryR sql=entries EntryR sql=entries
entryset EntrySetRId transaction TransactionRId OnDeleteCascade
account AccountRId currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text memo T.Text
value Rational value Rational
index EntryIndex
cachedValue (Maybe Rational)
cachedType (Maybe TransferType)
cachedLink (Maybe EntryIndex)
deriving Show Eq deriving Show Eq
TagRelationR sql=tag_relations TagRelationR sql=tag_relations
entry EntryRId entry EntryRId OnDeleteCascade
tag TagRId tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
entry EntryRId OnDeleteCascade
budgetName T.Text
deriving Show Eq deriving Show Eq
|] |]
newtype TxIndex = TxIndex {unTxIndex :: Int} data ConfigType = CTBudget | CTManual | CTImport
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql) deriving (Eq, Show, Read, Enum)
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype TxDesc = TxDesc {unTxDesc :: T.Text}
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
newtype Precision = Precision {unPrecision :: Word8}
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
type DaySpan = (Day, Int)
newtype CommitHash = CommitHash {unCommitHash :: Int}
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
deriving (Eq, Show, Read, Enum, Ord)
instance PersistFieldSql ConfigType where instance PersistFieldSql ConfigType where
sqlType _ = SqlString sqlType _ = SqlString
@ -127,61 +69,7 @@ instance PersistFieldSql ConfigType where
instance PersistField ConfigType where instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) = fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "not a string" fromPersistValue _ = Left "wrong type"
data AcntSign = Credit | Debit
deriving (Show, Eq, Ord)
instance PersistFieldSql AcntSign where
sqlType _ = SqlInt64
instance PersistField AcntSign where
toPersistValue Debit = PersistInt64 1
toPersistValue Credit = PersistInt64 (-1)
fromPersistValue (PersistInt64 1) = Right Debit
fromPersistValue (PersistInt64 (-1)) = Right Credit
fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
fromPersistValue _ = Left "not an Int64"
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Hashable, Generic, Read)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Hashable, Generic, Read)
acntPath2Text :: AcntPath -> T.Text
acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
instance PersistFieldSql AcntPath where
sqlType _ = SqlString
instance PersistField AcntPath where
toPersistValue = PersistText . acntPath2Text
fromPersistValue (PersistText v) = case T.split (== '/') v of
[] -> Left "path is empty"
(x : xs) -> case readMaybe $ T.unpack x of
Just t -> Right $ AcntPath t xs
_ -> Left "could not get account type"
fromPersistValue _ = Left "not a string"

View File

@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
import RIO import RIO
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA import Text.Regex.TDFA
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
makeHaskellTypesWith makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False}) (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -33,14 +33,13 @@ makeHaskellTypesWith
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher" , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter" , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType" , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag" , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type" , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@ -49,16 +48,12 @@ makeHaskellTypesWith
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type" , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
"Amount" , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
"Amount" , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type" SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor
"AcntMatcher_"
"AcntMatcher_"
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field" , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry" , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -66,9 +61,14 @@ makeHaskellTypesWith
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression" , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue" , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue" , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type" , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
, SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period" , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod" , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
] ]
deriveProduct deriveProduct
@ -87,13 +87,17 @@ deriveProduct
, "CronPat" , "CronPat"
, "DatePat" , "DatePat"
, "TaggedAcnt" , "TaggedAcnt"
, "Budget"
, "Income" , "Income"
, "ShadowTransfer"
, "TransferMatcher"
, "AcntSet"
, "DateMatcher" , "DateMatcher"
, "ValMatcher" , "ValMatcher"
, "YMDMatcher" , "YMDMatcher"
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter" , "EntryNumGetter"
, "LinkedNumGetter"
, "LinkedEntryNumGetter"
, "TemporalScope" , "TemporalScope"
, "SqlConfig" , "SqlConfig"
, "PretaxValue" , "PretaxValue"
@ -102,8 +106,8 @@ deriveProduct
, "TaxProgression" , "TaxProgression"
, "TaxMethod" , "TaxMethod"
, "PosttaxValue" , "PosttaxValue"
, "TransferValue" , "BudgetTransferValue"
, "TransferType" , "BudgetTransferType"
, "Period" , "Period"
, "PeriodType" , "PeriodType"
, "HourlyPeriod" , "HourlyPeriod"
@ -174,45 +178,25 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
deriving instance Hashable PairedTransfer deriving instance Hashable BudgetTransfer
deriving instance Generic PairedTransfer deriving instance Generic BudgetTransfer
deriving instance FromDhall PairedTransfer deriving instance FromDhall BudgetTransfer
newtype BudgetName = BudgetName {unBudgetName :: T.Text}
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Budget = Budget data Budget = Budget
{ bgtLabel :: !BudgetName { bgtLabel :: Text
, bgtIncomes :: ![Income] , bgtIncomes :: [Income]
, bgtPretax :: ![MultiAllocation PretaxValue] , bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: ![MultiAllocation TaxValue] , bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: ![MultiAllocation PosttaxValue] , bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: ![PairedTransfer] , bgtTransfers :: [BudgetTransfer]
, bgtShadowTransfers :: ![ShadowTransfer] , bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval) , bgtInterval :: !(Maybe Interval)
} }
deriving (Generic, Hashable, FromDhall)
data ShadowTransfer = ShadowTransfer
{ stFrom :: !TaggedAcnt
, stTo :: !TaggedAcnt
, stCurrency :: !CurID
, stDesc :: !Text
, stMatch :: !(TransferMatcher_ Text)
, stRatio :: !Double
}
deriving (Generic, Hashable, FromDhall)
data TransferMatcher_ re = TransferMatcher_
{ tmFrom :: !(Maybe (AcntMatcher_ re))
, tmTo :: !(Maybe (AcntMatcher_ re))
, tmDate :: !(Maybe DateMatcher)
, tmVal :: !ValMatcher
}
deriving instance Hashable PretaxValue deriving instance Hashable PretaxValue
@ -226,28 +210,17 @@ deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue deriving instance Hashable PosttaxValue
deriving instance Hashable TransferValue deriving instance Hashable Budget
deriving instance Hashable TransferType deriving instance Hashable BudgetTransferValue
deriving instance Read TransferType deriving instance Hashable BudgetTransferType
instance PersistFieldSql TransferType where
sqlType _ = SqlString
instance PersistField TransferType where
toPersistValue = PersistText . T.pack . show
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
deriving instance Hashable TaggedAcnt deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt deriving instance Ord TaggedAcnt
newtype CurID = CurID {unCurID :: T.Text} type CurID = T.Text
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Income = Income data Income = Income
{ incGross :: Double { incGross :: Double
@ -259,7 +232,6 @@ data Income = Income
, incFrom :: TaggedAcnt , incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt , incToBal :: TaggedAcnt
, incPayPeriod :: !Period , incPayPeriod :: !Period
, incPriority :: !Int
} }
deriving instance Hashable HourlyPeriod deriving instance Hashable HourlyPeriod
@ -278,13 +250,20 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v) deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
deriving instance (Show w, Show v) => Show (Amount w v) deriving instance (Show w, Show v) => Show (Amount w v)
deriving instance (Eq w, Eq v) => Eq (Amount w v) deriving instance (Eq w, Eq v) => Eq (Amount w v)
deriving instance Hashable Exchange
deriving instance Hashable BudgetCurrency
data Allocation w v = Allocation data Allocation w v = Allocation
{ alloTo :: TaggedAcnt { alloTo :: TaggedAcnt
, alloAmts :: [Amount w v] , alloAmts :: [Amount w v]
, alloCur :: CurID
} }
deriving (Eq, Show, Generic, Hashable) deriving (Eq, Show, Generic, Hashable)
@ -325,17 +304,11 @@ data Transfer a c w v = Transfer
} }
deriving (Eq, Show) deriving (Eq, Show)
deriving instance Generic (TransferMatcher_ Text) deriving instance Hashable ShadowTransfer
deriving instance Hashable (TransferMatcher_ Text) deriving instance Hashable AcntSet
deriving instance FromDhall (TransferMatcher_ Text) deriving instance Hashable TransferMatcher
deriving instance Generic (AcntMatcher_ Text)
deriving instance Hashable (AcntMatcher_ Text)
deriving instance FromDhall (AcntMatcher_ Text)
deriving instance Hashable ValMatcher deriving instance Hashable ValMatcher
@ -367,10 +340,6 @@ instance Ord DateMatcher where
deriving instance Hashable EntryNumGetter deriving instance Hashable EntryNumGetter
deriving instance Hashable LinkedNumGetter
deriving instance Hashable LinkedEntryNumGetter
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall -- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type -- account tree type
@ -393,7 +362,7 @@ data AccountRoot_ a = AccountRoot_
, arIncome :: ![a] , arIncome :: ![a]
, arLiabilities :: ![a] , arLiabilities :: ![a]
} }
deriving (Generic, Hashable) deriving (Generic)
type AccountRootF = AccountRoot_ (Fix AccountTreeF) type AccountRootF = AccountRoot_ (Fix AccountTreeF)
@ -402,8 +371,10 @@ deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree type AccountRoot = AccountRoot_ AccountTree
data Config_ a = Config_ data Config_ a = Config_
{ scope :: !TemporalScope { global :: !TemporalScope
, budget :: ![Budget]
, currencies :: ![Currency] , currencies :: ![Currency]
, statements :: ![History]
, accounts :: !a , accounts :: !a
, tags :: ![Tag] , tags :: ![Tag]
, sqlConfig :: !SqlConfig , sqlConfig :: !SqlConfig
@ -433,76 +404,55 @@ instance FromDhall a => FromDhall (Config_ a)
-- dhall type overrides (since dhall can't import types with parameters...yet) -- dhall type overrides (since dhall can't import types with parameters...yet)
-- TODO newtypes for these? -- TODO newtypes for these?
newtype AcntID = AcntID {unAcntID :: T.Text} type AcntID = T.Text
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
newtype TagID = TagID {unTagID :: T.Text} type TagID = T.Text
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type HistTransfer = Transfer AcntID CurID DatePat Double
deriving instance Generic HistTransfer
deriving instance Hashable HistTransfer
deriving instance FromDhall HistTransfer
data History data History
= HistTransfer !PairedTransfer = HistTransfer !HistTransfer
| HistStatement !Statement | HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall) deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter n = Entry EntryAcnt n TagID type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
type FromEntryGetter = EntryGetter EntryNumGetter instance FromDhall EntryGetter
type ToEntryGetter = EntryGetter LinkedEntryNumGetter deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
instance FromDhall FromEntryGetter deriving instance Generic (Entry a v c t)
instance FromDhall ToEntryGetter deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
deriving instance (Show a, Show v, Show t) => Show (Entry a v t) deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
deriving instance Generic (Entry a v t) data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txEntries :: ![s]
}
deriving (Generic)
deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t) type ExpTx = Tx EntryGetter
deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t) instance FromDhall ExpTx
deriving instance Eq a => Eq (TxOpts a) data TxOpts re = TxOpts
{ toDate :: !T.Text
deriving instance Generic (TxOpts a) , toAmount :: !T.Text
, toDesc :: !T.Text
deriving instance Hashable (TxOpts T.Text) , toOther :: ![T.Text]
, toDateFmt :: !T.Text
deriving instance FromDhall (TxOpts T.Text) , toAmountFmt :: !re
}
deriving instance Show a => Show (TxOpts a) deriving (Eq, Generic, Hashable, Show, FromDhall)
deriving instance Eq re => Eq (TxAmount1 re)
deriving instance Eq re => Eq (TxAmount2 re)
deriving instance Show re => Show (TxAmount1 re)
deriving instance Show re => Show (TxAmount2 re)
deriving instance Generic (TxAmount1 T.Text)
deriving instance Generic (TxAmount2 T.Text)
deriving instance Hashable (TxAmount1 T.Text)
deriving instance Hashable (TxAmount2 T.Text)
deriving instance FromDhall (TxAmount1 T.Text)
deriving instance FromDhall (TxAmount2 T.Text)
deriving instance Functor TxAmount1
deriving instance Functor TxAmount2
deriving instance Foldable TxAmount1
deriving instance Foldable TxAmount2
deriving instance Traversable TxAmount1
deriving instance Traversable TxAmount2
data Statement = Statement data Statement = Statement
{ stmtPaths :: ![FilePath] { stmtPaths :: ![FilePath]
@ -511,30 +461,7 @@ data Statement = Statement
, stmtTxOpts :: !(TxOpts T.Text) , stmtTxOpts :: !(TxOpts T.Text)
, stmtSkipLines :: !Natural , stmtSkipLines :: !Natural
} }
deriving (Eq, Hashable, Generic, FromDhall, Show) deriving (Eq, Hashable, Generic, FromDhall)
data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
deriving (Eq, Show, Functor, Foldable, Traversable)
deriving instance Generic (TxAmountSpec T.Text)
deriving instance FromDhall (TxAmountSpec T.Text)
deriving instance Hashable (TxAmountSpec T.Text)
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !(TxAmountSpec re)
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toSkipBlankDate :: !Bool
, toSkipBlankAmount :: !Bool
, toSkipBlankDescription :: !Bool
, toSkipBlankOther :: ![Text]
, toSkipMissingFields :: !Bool
}
deriving (Functor, Foldable, Traversable)
-- | the value of a field in entry (text version) -- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map -- can either be a raw (constant) value, a lookup from the record, or a map
@ -544,7 +471,7 @@ data EntryTextGetter t
| LookupT !T.Text | LookupT !T.Text
| MapT !(FieldMap T.Text t) | MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t) | Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall, Functor) deriving (Eq, Generic, Hashable, Show, FromDhall)
type EntryCur = EntryTextGetter CurID type EntryCur = EntryTextGetter CurID
@ -576,32 +503,10 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text) deriving instance Show (FieldMatcher T.Text)
data TxHalfGetter e = TxHalfGetter
{ thgAcnt :: !EntryAcnt
, thgComment :: !T.Text
, thgTags :: ![TagID]
, thgEntries :: ![e]
}
deriving (Eq, Generic, Hashable, Show)
deriving instance FromDhall (TxHalfGetter FromEntryGetter)
deriving instance FromDhall (TxHalfGetter ToEntryGetter)
data TxSubGetter = TxSubGetter
{ tsgFrom :: !(TxHalfGetter FromEntryGetter)
, tsgTo :: !(TxHalfGetter ToEntryGetter)
, tsgValue :: !EntryNumGetter
, tsgCurrency :: !EntryCur
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data TxGetter = TxGetter data TxGetter = TxGetter
{ tgFrom :: !(TxHalfGetter FromEntryGetter) { tgCurrency :: !EntryCur
, tgTo :: !(TxHalfGetter ToEntryGetter) , tgAcnt :: !EntryAcnt
, tgCurrency :: !EntryCur , tgEntries :: ![EntryGetter]
, tgOtherEntries :: ![TxSubGetter]
, tgScale :: !Double
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)

View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
@ -11,11 +12,11 @@ module Internal.Types.Main
where where
import Control.Monad.Except import Control.Monad.Except
import Data.Decimal
import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.Sql hiding (Desc, In, Statement)
import Dhall hiding (embed, maybe) import Dhall hiding (embed, maybe)
import Internal.Types.Database import Internal.Types.Database
import Internal.Types.Dhall import Internal.Types.Dhall
import Language.Haskell.TH.Syntax (Lift)
import RIO import RIO
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE import qualified RIO.NonEmpty as NE
@ -26,166 +27,99 @@ import Text.Regex.TDFA
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- database cache types -- database cache types
type MonadFinance = MonadReader TxState data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
data DeleteTxs = DeleteTxs , chExpense :: ![Int]
{ dtCommits :: ![CommitRId] , chManual :: ![Int]
, dtTxs :: ![TransactionRId] , chImport :: ![Int]
, dtEntrySets :: ![EntrySetRId]
, dtEntries :: ![EntryRId]
, dtTagRelations :: ![TagRelationRId]
}
deriving (Show)
type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
data MetaCRUD = MetaCRUD
{ mcCurrencies :: !(EntityCRUDOps CurrencyR)
, mcAccounts :: !(EntityCRUDOps AccountR)
, mcPaths :: !(EntityCRUDOps AccountPathR)
, mcTags :: !(EntityCRUDOps TagR)
, mcBudgetScope :: !BudgetSpan
, mcHistoryScope :: !HistorySpan
} }
type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type PreBudgetCRUD = BudgetCRUDOps Budget type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
type HistoryCRUDOps h =
CRUDOps
h
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
data TxState = TxState
{ tsAccountMap :: !AccountMap
, tsCurrencyMap :: !CurrencyMap
, tsTagMap :: !TagMap
, tsBudgetScope :: !BudgetSpan
, tsHistoryScope :: !HistorySpan
}
deriving (Show)
data ExistingConfig = ExistingConfig
{ ecAccounts :: !(Set AccountRId)
, ecTags :: !(Set TagRId)
, ecCurrencies :: !(Set CurrencyRId)
}
type AccountMap = M.Map AcntID (AccountRId, AcntType)
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
deriving (Show)
type CurrencyMap = M.Map CurID CurrencyPrec
type TagMap = M.Map TagID TagRId type TagMap = M.Map TagID TagRId
data CRUDOps c r u d = CRUDOps data DBState = DBState
{ coCreate :: !c { kmCurrency :: !CurrencyMap
, coRead :: !r , kmAccount :: !AccountMap
, coUpdate :: !u , kmTag :: !TagMap
, coDelete :: !d , kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
} }
deriving (Show)
data CachedEntry data DBUpdates = DBUpdates
= CachedLink EntryIndex LinkScale { duOldCommits :: ![Int]
| CachedBalance Decimal , duNewTagIds :: ![Entity TagR]
| CachedPercent Double , duNewAcntPaths :: ![AccountPathR]
, duNewAcntIds :: ![Entity AccountR]
data TxSortKey = TxSortKey , duNewCurrencyIds :: ![Entity CurrencyR]
{ tskDate :: !Day
, tskPriority :: !Int
, tskDesc :: !TxDesc
} }
deriving (Show, Eq, Ord)
-- TODO this should actually be a ReadTx since it will be compared with other type CurrencyM = Reader CurrencyMap
-- Tx's to get the insert/update order correct
data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId
, reAcnt :: !AccountRId
, reValue :: !Decimal
, reIndex :: !EntryIndex
, reESIndex :: !EntrySetIndex
, reSortKey :: !TxSortKey
}
deriving (Show)
data UpdateEntry i v = UpdateEntry type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
{ ueID :: !i
, ueAcnt :: !AccountRId
, ueValue :: !v
, ueIndex :: !EntryIndex
}
deriving (Show)
deriving instance Functor (UpdateEntry i) type KeyTx = Tx KeyEntry
newtype LinkScale = LinkScale {unLinkScale :: Double} type TreeR = Tree ([T.Text], AccountRId)
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
newtype StaticValue = StaticValue {unStaticValue :: Decimal} type MonadFinance = MonadReader DBState
deriving newtype (Num, Show)
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show) askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
type UEUnk = UpdateEntry EntryRId EntryValueUnk
type UELink = UpdateEntry EntryRId LinkScale
type UEBlank = UpdateEntry EntryRId ()
type UE_RO = UpdateEntry () StaticValue
type UEBalanced = UpdateEntry EntryRId StaticValue
data UpdateEntrySet f t = UpdateEntrySet
{ utFrom0 :: !f
, utTo0 :: !UEBlank
, utFromUnk :: ![(UEUnk, [UELink])]
, utToUnk :: ![UEUnk]
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utTotalValue :: !t
, utIndex :: !EntrySetIndex
, utSortKey :: !TxSortKey
}
deriving (Show)
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryCRU
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry
| ToInsert (Tx CommitR)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- misc -- misc
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord data TxRecord = TxRecord
{ trDate :: !Day { trDate :: !Day
, trAmount :: !Decimal , trAmount :: !Rational
, trDesc :: !TxDesc , trDesc :: !T.Text
, trOther :: !(M.Map T.Text T.Text) , trOther :: !(M.Map T.Text T.Text)
, trFile :: !FilePath , trFile :: !FilePath
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
type DaySpan = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit accountSign AssetT = Debit
accountSign ExpenseT = Debit accountSign ExpenseT = Debit
@ -193,81 +127,21 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit accountSign LiabilityT = Credit
accountSign EquityT = Credit accountSign EquityT = Credit
data HalfEntrySet v0 vN = HalfEntrySet type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
{ hesPrimary :: !(Entry AcntID v0 TagID)
, hesOther :: ![Entry AcntID vN TagID]
}
deriving (Show)
data EntrySet v0 vp0 vpN vtN = EntrySet type BalEntry = Entry AcntID Rational CurID TagID
{ esTotalValue :: !v0
, esCurrency :: !CurrencyRId
, esFrom :: !(HalfEntrySet vp0 vpN)
, esTo :: !(HalfEntrySet () vtN)
}
deriving (Show)
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN type RawTx = Tx RawEntry
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN type BalTx = Tx BalEntry
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
type TransferEntrySet = SecondayEntrySet
type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data TxMeta k = TxMeta
{ txmDate :: !Day
, txmPriority :: !Int
, txmDesc :: !TxDesc
, txmCommit :: !k
}
deriving (Show, Eq, Ord)
data Tx k = Tx
{ txMeta :: !(TxMeta k)
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
}
deriving (Generic, Show)
data InsertEntry = InsertEntry
{ ieCached :: !(Maybe CachedEntry)
, ieEntry :: !(Entry AccountRId Decimal TagRId)
}
data InsertEntrySet = InsertEntrySet
{ iesCurrency :: !CurrencyRId
, iesFromEntries :: !(NonEmpty InsertEntry)
, iesToEntries :: !(NonEmpty InsertEntry)
}
data InsertTx = InsertTx
{ itxMeta :: !(TxMeta CommitR)
, itxEntrySets :: !(NonEmpty InsertEntrySet)
}
deriving (Generic)
data EntryValue_ a = EntryValue_ TransferType a
deriving (Show, Functor, Foldable, Traversable)
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
deriving (Show, Eq, Ord)
data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
deriving (Show)
data MatchRes a = MatchPass !a | MatchFail | MatchSkip data MatchRes a = MatchPass !a | MatchFail | MatchSkip
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- exception types -- exception types
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show) data MatchType = MatchNumeric | MatchText deriving (Show)
data EntryIDType = AcntField | CurField | TagField deriving (Show) data EntryIDType = AcntField | CurField | TagField deriving (Show)
@ -279,53 +153,50 @@ data LookupSuberr
| DBKey !EntryIDType | DBKey !EntryIDType
deriving (Show) deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show) data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data DBLinkSubError data InsertError
= DBLinkNoScale
| DBLinkNoValue
| DBLinkInvalidValue !Rational !Bool
| DBLinkInvalidBalance
| DBLinkInvalidPercent
deriving (Show)
data DBSubError
= DBShouldBeEmpty
| DBMultiScope
| DBUpdateUnbalanced
| DBLinkError !EntryRId !DBLinkSubError
deriving (Show)
data AppError
= RegexError !T.Text = RegexError !T.Text
| MatchValPrecisionError !Natural !Natural | MatchValPrecisionError !Natural !Natural
| AccountTypeError !AcntID !(NE.NonEmpty AcntType) | AccountError !AcntID !(NE.NonEmpty AcntType)
| StatementIOError !T.Text | InsertIOError !T.Text
| ParseError !T.Text | ParseError !T.Text
| ConversionError !T.Text !Bool | ConversionError !T.Text
| LookupError !LookupSuberr !T.Text | LookupError !LookupSuberr !T.Text
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | BalanceError !BalanceType !CurID ![RawEntry]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian) | DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![StatementParserRe] | StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day | PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex
| DBError !DBSubError
deriving (Show) deriving (Show)
newtype AppException = AppException [AppError] newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [AppError] deriving (Show, Semigroup) via [InsertError]
instance Exception AppException instance Exception InsertException
type MonadAppError = MonadError AppException type MonadInsertError = MonadError InsertException
type AppExceptT = ExceptT AppException type InsertExceptT = ExceptT InsertException
type AppExcept = AppExceptT Identity type InsertExcept = InsertExceptT Identity
type StatementParserRe = StatementParser (T.Text, Regex) data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type TransferMatcherRe = TransferMatcher_ Regex type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex) type TxOptsRe = TxOpts (T.Text, Regex)

File diff suppressed because it is too large Load Diff

View File

@ -87,7 +87,6 @@ dependencies:
- filepath - filepath
- mtl - mtl
- persistent-mtl >= 0.3.0.0 - persistent-mtl >= 0.3.0.0
- Decimal >= 0.5.2
library: library:
source-dirs: lib/ source-dirs: lib/