Compare commits
No commits in common. "master" and "update_dhall_types" have entirely different histories.
master
...
update_dha
119
app/Main.hs
119
app/Main.hs
|
|
@ -2,21 +2,20 @@
|
|||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Rerunnable
|
||||
import Control.Monad.Logger
|
||||
import Data.Bitraversable
|
||||
-- import Data.Hashable
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Text.IO as TI
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Dhall hiding (double, record)
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
import Database.Persist.Monad
|
||||
import Internal.Config
|
||||
import Internal.Database.Ops
|
||||
import Internal.Insert
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import Options.Applicative
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
-- import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -30,26 +29,14 @@ main = parse =<< execParser o
|
|||
<> header "pwncash - your budget, your life"
|
||||
)
|
||||
|
||||
type ConfigPath = FilePath
|
||||
|
||||
type BudgetPath = FilePath
|
||||
|
||||
type HistoryPath = FilePath
|
||||
|
||||
data Options = Options !ConfigPath !Mode
|
||||
data Options = Options FilePath Mode
|
||||
|
||||
data Mode
|
||||
= Reset
|
||||
| DumpCurrencies
|
||||
| DumpAccounts
|
||||
| DumpAccountKeys
|
||||
| Sync !SyncOptions
|
||||
|
||||
data SyncOptions = SyncOptions
|
||||
{ syncBudgets :: ![BudgetPath]
|
||||
, syncHistories :: ![HistoryPath]
|
||||
, syncThreads :: !Int
|
||||
}
|
||||
| Sync
|
||||
|
||||
configFile :: Parser FilePath
|
||||
configFile =
|
||||
|
|
@ -67,7 +54,7 @@ options =
|
|||
<|> getConf dumpCurrencies
|
||||
<|> getConf dumpAccounts
|
||||
<|> getConf dumpAccountKeys
|
||||
<|> getConf sync_
|
||||
<|> getConf sync
|
||||
where
|
||||
getConf m = Options <$> configFile <*> m
|
||||
|
||||
|
|
@ -108,43 +95,14 @@ dumpAccountKeys =
|
|||
<> help "Dump all account keys/aliases"
|
||||
)
|
||||
|
||||
sync_ :: Parser Mode
|
||||
sync_ =
|
||||
sync :: Parser Mode
|
||||
sync =
|
||||
flag'
|
||||
Sync
|
||||
( long "sync"
|
||||
<> short 'S'
|
||||
<> 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 c Reset) = do
|
||||
|
|
@ -153,8 +111,7 @@ parse (Options c Reset) = do
|
|||
parse (Options c DumpAccounts) = runDumpAccounts c
|
||||
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
||||
parse (Options c DumpCurrencies) = runDumpCurrencies c
|
||||
parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
|
||||
runSync syncThreads c syncBudgets syncHistories
|
||||
parse (Options c Sync) = runSync c
|
||||
|
||||
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
|
||||
runDumpCurrencies c = do
|
||||
|
|
@ -192,34 +149,44 @@ runDumpAccountKeys c = do
|
|||
ar <- accounts <$> readConfig c
|
||||
let ks =
|
||||
paths2IDs $
|
||||
fmap (double . accountRFullpath . E.entityVal) $
|
||||
fst $
|
||||
indexAcntRoot ar
|
||||
fmap (double . fst) $
|
||||
concatMap (t3 . uncurry tree2Records) $
|
||||
flattenAcntRoot ar
|
||||
mapM_ (uncurry printPair) ks
|
||||
where
|
||||
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)
|
||||
|
||||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||
runSync threads c bs hs = do
|
||||
setNumCapabilities threads
|
||||
runSync :: FilePath -> IO ()
|
||||
runSync c = do
|
||||
config <- readConfig c
|
||||
(bs', hs') <-
|
||||
fmap (bimap concat concat . partitionEithers) $
|
||||
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
|
||||
(Left <$> bs) ++ (Right <$> hs)
|
||||
let (hTs, hSs) = splitHistory $ statements config
|
||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||
setNumCapabilities 1
|
||||
handle err $ sync pool root config bs' hs'
|
||||
handle err $ do
|
||||
-- _ <- askLoggerIO
|
||||
|
||||
-- get the current DB state
|
||||
s <- runSqlQueryT pool $ do
|
||||
runMigration migrateAll
|
||||
fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
|
||||
|
||||
-- read desired statements from disk
|
||||
bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs
|
||||
|
||||
-- update the DB
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
|
||||
let hTransRes = mapErrors insertHistTransfer hTs
|
||||
let bgtRes = mapErrors insertBudget $ budget config
|
||||
updateDBState -- TODO this will only work if foreign keys are deferred
|
||||
res <- runExceptT $ do
|
||||
mapM_ (uncurry insertHistStmt) bSs
|
||||
combineError hTransRes bgtRes $ \_ _ -> ()
|
||||
rerunnableIO $ fromEither res
|
||||
where
|
||||
root = takeDirectory c
|
||||
err (AppException es) = do
|
||||
err (InsertException es) = do
|
||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||
exitFailure
|
||||
|
||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||
readConfig = fmap unfix . readDhall
|
||||
|
||||
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
|
||||
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
|
||||
-- showBalances
|
||||
|
|
|
|||
19
budget.cabal
19
budget.cabal
|
|
@ -25,13 +25,12 @@ source-repository head
|
|||
|
||||
library
|
||||
exposed-modules:
|
||||
Internal.Budget
|
||||
Internal.Database
|
||||
Internal.History
|
||||
Internal.Types.Database
|
||||
Internal.Types.Dhall
|
||||
Internal.Types.Main
|
||||
Internal.Types.TH
|
||||
Internal.Config
|
||||
Internal.Database.Ops
|
||||
Internal.Insert
|
||||
Internal.Statement
|
||||
Internal.TH
|
||||
Internal.Types
|
||||
Internal.Utils
|
||||
other-modules:
|
||||
Paths_budget
|
||||
|
|
@ -75,8 +74,7 @@ library
|
|||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||
build-depends:
|
||||
Decimal >=0.5.2
|
||||
, base >=4.12 && <10
|
||||
base >=4.12 && <10
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
, containers >=0.6.4.1
|
||||
|
|
@ -145,8 +143,7 @@ executable pwncash
|
|||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||
build-depends:
|
||||
Decimal >=0.5.2
|
||||
, base >=4.12 && <10
|
||||
base >=4.12 && <10
|
||||
, budget
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
|
|
|
|||
|
|
@ -278,124 +278,49 @@ let DatePat =
|
|||
-}
|
||||
< Cron : CronPat.Type | Mod : ModPat.Type >
|
||||
|
||||
let TxAmount1_ =
|
||||
\(re : Type) ->
|
||||
{ a1Column : Text
|
||||
, 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 :
|
||||
{-
|
||||
Column title for date
|
||||
-}
|
||||
Text
|
||||
, toAmount :
|
||||
{-
|
||||
Column title for amount
|
||||
-}
|
||||
TxAmountSpec_ re
|
||||
, toDesc :
|
||||
{-
|
||||
Column title for description
|
||||
-}
|
||||
Text
|
||||
, toOther :
|
||||
{-
|
||||
Titles of other columns to include; these will be available in
|
||||
a map for use in downstream processing (see 'Field')
|
||||
-}
|
||||
List Text
|
||||
, toDateFmt :
|
||||
{-
|
||||
Format of the date field as specified in the
|
||||
Data.Time.Format.formattime Haskell function.
|
||||
-}
|
||||
Text
|
||||
, toSkipBlankDate :
|
||||
{-
|
||||
Skip line if date field is a blank
|
||||
-}
|
||||
Bool
|
||||
, 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
|
||||
{- Additional metadata to use when parsing a statement -}
|
||||
{ Type =
|
||||
{ toDate :
|
||||
{-
|
||||
Column title for date
|
||||
-}
|
||||
Text
|
||||
, toAmount :
|
||||
{-
|
||||
Column title for amount
|
||||
-}
|
||||
Text
|
||||
, toDesc :
|
||||
{-
|
||||
Column title for description
|
||||
-}
|
||||
Text
|
||||
, toOther :
|
||||
{-
|
||||
Titles of other columns to include; these will be available in
|
||||
a map for use in downstream processing (see 'Field')
|
||||
-}
|
||||
List Text
|
||||
, toDateFmt :
|
||||
{-
|
||||
Format of the date field as specified in the
|
||||
Data.Time.Format.formattime Haskell function.
|
||||
-}
|
||||
Text
|
||||
, toAmountFmt :
|
||||
{- Format of the amount field. Must include three fields for the
|
||||
sign, numerator, and denominator of the amount.
|
||||
-}
|
||||
Text
|
||||
}
|
||||
, default =
|
||||
{ toDate = "Date"
|
||||
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
|
||||
, toAmount = "Amount"
|
||||
, toDesc = "Description"
|
||||
, toOther = [] : List Text
|
||||
, toDateFmt = "%0m/%0d/%Y"
|
||||
, toSkipBlankDate = False
|
||||
, toSkipBlankAmount = False
|
||||
, toSkipBlankDescription = False
|
||||
, toSkipBlankOther = [] : List Text
|
||||
, toSkipMissingFields = False
|
||||
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -477,45 +402,9 @@ let EntryNumGetter =
|
|||
|
||||
LookupN: lookup the value from a field
|
||||
ConstN: a constant value
|
||||
AmountN: the value of the 'Amount' column times a scaling factor
|
||||
BalanceN: the amount required to make the target account reach a balance
|
||||
PercentN: the amount required to make an account reach a given percentage
|
||||
AmountN: the value of the 'Amount' column
|
||||
-}
|
||||
< LookupN : Text
|
||||
| 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 >
|
||||
< LookupN : Text | ConstN : Double | AmountN >
|
||||
|
||||
let EntryTextGetter =
|
||||
{-
|
||||
|
|
@ -554,6 +443,7 @@ let Entry =
|
|||
-}
|
||||
\(a : Type) ->
|
||||
\(v : Type) ->
|
||||
\(c : Type) ->
|
||||
\(t : Type) ->
|
||||
{ eAcnt :
|
||||
{-
|
||||
|
|
@ -565,6 +455,11 @@ let Entry =
|
|||
Pertains to value for this entry.
|
||||
-}
|
||||
v
|
||||
, eCurrency :
|
||||
{-
|
||||
Pertains to value for this entry.
|
||||
-}
|
||||
c
|
||||
, eComment :
|
||||
{-
|
||||
A short description of this entry (if none, use a blank string)
|
||||
|
|
@ -579,107 +474,35 @@ let Entry =
|
|||
|
||||
let EntryGetter =
|
||||
{-
|
||||
Means for getting an entry from a given row in a statement (debit side)
|
||||
-}
|
||||
\(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
|
||||
Means for getting an entry from a given row in a statement
|
||||
-}
|
||||
{ Type =
|
||||
{ tsgValue : EntryNumGetter
|
||||
, tsgCurrency : EntryCurGetter
|
||||
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
||||
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
||||
}
|
||||
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
|
||||
Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
|
||||
, default = { eValue = None EntryNumGetter, eComment = "" }
|
||||
}
|
||||
|
||||
let TxGetter =
|
||||
{-
|
||||
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 =
|
||||
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
||||
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
||||
, tgScale : Double
|
||||
, tgCurrency : EntryCurGetter
|
||||
, tgOtherEntries : List TxSubGetter.Type
|
||||
}
|
||||
, default =
|
||||
{ tgOtherEntries = [] : List TxSubGetter.Type
|
||||
, tgFrom = TxHalfGetter
|
||||
, tgTo = TxHalfGetter
|
||||
, tgScale = 1.0
|
||||
}
|
||||
{ tgEntries :
|
||||
{-
|
||||
A means of getting entries for this transaction (minimum 1)
|
||||
-}
|
||||
List EntryGetter.Type
|
||||
, tgCurrency :
|
||||
{-
|
||||
Currency against which entries in this transaction will be balanced
|
||||
-}
|
||||
EntryCurGetter
|
||||
, tgAcnt :
|
||||
{-
|
||||
Account in which entries in this transaction will be balanced
|
||||
-}
|
||||
EntryAcntGetter
|
||||
}
|
||||
|
||||
let StatementParser_ =
|
||||
|
|
@ -719,7 +542,7 @@ let StatementParser_ =
|
|||
a transaction. If none, don't make a transaction (eg 'skip'
|
||||
this row in the statement).
|
||||
-}
|
||||
Optional TxGetter.Type
|
||||
Optional TxGetter
|
||||
, spTimes :
|
||||
{-
|
||||
Match at most this many rows; if none there is no limit
|
||||
|
|
@ -736,7 +559,7 @@ let StatementParser_ =
|
|||
, spVal = ValMatcher::{=}
|
||||
, spDesc = None Text
|
||||
, spOther = [] : List (FieldMatcher_ re)
|
||||
, spTx = None TxGetter.Type
|
||||
, spTx = None TxGetter
|
||||
, spTimes = None Natural
|
||||
, spPriority = +0
|
||||
}
|
||||
|
|
@ -754,29 +577,7 @@ let Amount =
|
|||
-}
|
||||
\(w : Type) ->
|
||||
\(v : Type) ->
|
||||
{ Type =
|
||||
{ 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
|
||||
}
|
||||
{ amtWhen : w, amtValue : v, amtDesc : Text }
|
||||
|
||||
let Transfer =
|
||||
{-
|
||||
|
|
@ -789,24 +590,14 @@ let Transfer =
|
|||
{ transFrom : a
|
||||
, transTo : a
|
||||
, 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 =
|
||||
{-
|
||||
A manually specified historical transfer
|
||||
-}
|
||||
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
|
||||
|
||||
let TransferAmount = Amount DatePat TransferValue.Type
|
||||
Transfer AcntID CurID DatePat Double
|
||||
|
||||
let Statement =
|
||||
{-
|
||||
|
|
@ -843,6 +634,44 @@ let History =
|
|||
-}
|
||||
< 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 =
|
||||
{-
|
||||
How to allocate a given budget stream. This can be thought of as a Transfer
|
||||
|
|
@ -850,7 +679,12 @@ let Allocation =
|
|||
-}
|
||||
\(w : 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 =
|
||||
{-
|
||||
|
|
@ -945,8 +779,6 @@ let SingleAllocation =
|
|||
-}
|
||||
Allocation {}
|
||||
|
||||
let SingleAlloAmount = \(v : Type) -> Amount {} v
|
||||
|
||||
let MultiAllocation =
|
||||
{-
|
||||
An allocation specialized to capturing multiple income streams within a given
|
||||
|
|
@ -955,8 +787,6 @@ let MultiAllocation =
|
|||
-}
|
||||
Allocation Interval
|
||||
|
||||
let MultiAlloAmount = \(v : Type) -> Amount Interval v
|
||||
|
||||
let HourlyPeriod =
|
||||
{-
|
||||
Definition for a pay period denominated in hours
|
||||
|
|
@ -1039,62 +869,85 @@ let Income =
|
|||
This must be an income AcntID, and is the only place income
|
||||
accounts may be specified in the entire budget.
|
||||
-}
|
||||
TaggedAcnt.Type
|
||||
TaggedAcnt
|
||||
, incToBal :
|
||||
{-
|
||||
The account to which to send the remainder of the income stream
|
||||
(if any) after all allocations have been applied.
|
||||
-}
|
||||
TaggedAcnt.Type
|
||||
, incPriority : Integer
|
||||
TaggedAcnt
|
||||
}
|
||||
, default =
|
||||
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
||||
, incTaxes = [] : List (SingleAllocation TaxValue)
|
||||
, 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 = { amPat : re, amInvert : Bool }, default.amInvert = False }
|
||||
{ Type =
|
||||
{ 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
|
||||
fashion)
|
||||
-}
|
||||
\(re : Type) ->
|
||||
{ tmFrom : Optional (AcntMatcher_ re).Type
|
||||
, tmTo : Optional (AcntMatcher_ re).Type
|
||||
, tmDate :
|
||||
{-
|
||||
If given, means to match the date of a transfer.
|
||||
-}
|
||||
Optional DateMatcher
|
||||
, tmVal :
|
||||
{-
|
||||
If given, means to match the value of a transfer.
|
||||
-}
|
||||
ValMatcher.Type
|
||||
}
|
||||
|
||||
let TransferMatcher =
|
||||
{ Type = TransferMatcher_ Text
|
||||
{ Type =
|
||||
{ tmFrom :
|
||||
{-
|
||||
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 :
|
||||
{-
|
||||
If given, means to match the date of a transfer.
|
||||
-}
|
||||
Optional DateMatcher
|
||||
, tmVal :
|
||||
{-
|
||||
If given, means to match the value of a transfer.
|
||||
-}
|
||||
ValMatcher.Type
|
||||
}
|
||||
, default =
|
||||
{ tmFrom = None AcntMatcher.Type
|
||||
, tmTo = None AcntMatcher.Type
|
||||
{ tmFrom = AcntSet.default
|
||||
, tmTo = AcntSet.default
|
||||
, tmDate = None DateMatcher
|
||||
, 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 =
|
||||
{-
|
||||
A transaction analogous to another transfer with given properties.
|
||||
|
|
@ -1103,17 +956,17 @@ let ShadowTransfer =
|
|||
{-
|
||||
Source of this transfer
|
||||
-}
|
||||
TaggedAcnt.Type
|
||||
TaggedAcnt
|
||||
, stTo :
|
||||
{-
|
||||
Destination of this transfer.
|
||||
-}
|
||||
TaggedAcnt.Type
|
||||
TaggedAcnt
|
||||
, stCurrency :
|
||||
{-
|
||||
Currency of this transfer.
|
||||
-}
|
||||
CurID
|
||||
BudgetCurrency
|
||||
, stDesc :
|
||||
{-
|
||||
Description of this transfer.
|
||||
|
|
@ -1127,6 +980,7 @@ let ShadowTransfer =
|
|||
specified in other fields of this type.
|
||||
-}
|
||||
TransferMatcher.Type
|
||||
, stType : BudgetTransferType
|
||||
, stRatio :
|
||||
{-
|
||||
Fixed multipler to translate value of matched transfer to this one.
|
||||
|
|
@ -1134,11 +988,17 @@ let ShadowTransfer =
|
|||
Double
|
||||
}
|
||||
|
||||
let BudgetTransferValue =
|
||||
{-
|
||||
Means to determine the value of a budget transfer.
|
||||
-}
|
||||
{ btVal : Double, btType : BudgetTransferType }
|
||||
|
||||
let BudgetTransfer =
|
||||
{-
|
||||
A manually specified transaction for a budget
|
||||
-}
|
||||
HistTransfer
|
||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||
|
||||
let Budget =
|
||||
{-
|
||||
|
|
@ -1158,7 +1018,6 @@ let Budget =
|
|||
, bgtPosttax : List (MultiAllocation PosttaxValue)
|
||||
, bgtTransfers : List BudgetTransfer
|
||||
, bgtShadowTransfers : List ShadowTransfer
|
||||
, bgtInterval : Optional Interval
|
||||
}
|
||||
|
||||
in { CurID
|
||||
|
|
@ -1180,7 +1039,6 @@ in { CurID
|
|||
, CronPat
|
||||
, DatePat
|
||||
, TxOpts
|
||||
, TxOpts_
|
||||
, StatementParser
|
||||
, StatementParser_
|
||||
, ValMatcher
|
||||
|
|
@ -1189,13 +1047,10 @@ in { CurID
|
|||
, FieldMatcher
|
||||
, FieldMatcher_
|
||||
, EntryNumGetter
|
||||
, LinkedEntryNumGetter
|
||||
, LinkedNumGetter
|
||||
, Field
|
||||
, FieldMap
|
||||
, Entry
|
||||
, FromEntryGetter
|
||||
, ToEntryGetter
|
||||
, EntryGetter
|
||||
, EntryTextGetter
|
||||
, EntryCurGetter
|
||||
, EntryAcntGetter
|
||||
|
|
@ -1206,11 +1061,12 @@ in { CurID
|
|||
, Budget
|
||||
, Allocation
|
||||
, Amount
|
||||
, TransferMatcher_
|
||||
, TransferMatcher
|
||||
, ShadowTransfer
|
||||
, AcntSet
|
||||
, BudgetCurrency
|
||||
, Exchange
|
||||
, TaggedAcnt
|
||||
, AccountTree
|
||||
, Account
|
||||
, Placeholder
|
||||
, PretaxValue
|
||||
|
|
@ -1219,29 +1075,13 @@ in { CurID
|
|||
, TaxProgression
|
||||
, TaxMethod
|
||||
, TaxValue
|
||||
, TransferValue
|
||||
, TransferType
|
||||
, BudgetTransferValue
|
||||
, BudgetTransferType
|
||||
, TxGetter
|
||||
, TxSubGetter
|
||||
, TxHalfGetter
|
||||
, FromTxHalfGetter
|
||||
, ToTxHalfGetter
|
||||
, HistTransfer
|
||||
, SingleAllocation
|
||||
, MultiAllocation
|
||||
, HourlyPeriod
|
||||
, Period
|
||||
, PeriodType
|
||||
, TransferAmount
|
||||
, MultiAlloAmount
|
||||
, SingleAlloAmount
|
||||
, AcntMatcher_
|
||||
, AcntMatcher
|
||||
, TxAmountSpec
|
||||
, TxAmountSpec_
|
||||
, TxAmount1_
|
||||
, TxAmount2_
|
||||
, TxAmount1
|
||||
, TxAmount2
|
||||
, BudgetTransfer
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,10 +4,18 @@ let List/map =
|
|||
|
||||
let T = ./Types.dhall
|
||||
|
||||
let nullEntry =
|
||||
let nullSplit =
|
||||
\(a : T.EntryAcntGetter) ->
|
||||
\(v : T.EntryNumGetter) ->
|
||||
T.FromEntryGetter::{ eAcnt = a, eValue = v }
|
||||
\(c : T.EntryCurGetter) ->
|
||||
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 =
|
||||
\(by : Natural) ->
|
||||
|
|
@ -19,22 +27,21 @@ let cron1 =
|
|||
\(m : Natural) ->
|
||||
\(d : Natural) ->
|
||||
T.DatePat.Cron
|
||||
T.CronPat::{
|
||||
, cpYear = Some (T.MDYPat.Single y)
|
||||
, cpMonth = Some (T.MDYPat.Single m)
|
||||
, cpDay = Some (T.MDYPat.Single d)
|
||||
}
|
||||
( nullCron
|
||||
// { cpYear = Some (T.MDYPat.Single y)
|
||||
, cpMonth = Some (T.MDYPat.Single m)
|
||||
, 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 =
|
||||
\(n : Natural) ->
|
||||
\(x : T.TxGetter.Type) ->
|
||||
matchInf x // { spTimes = Some n }
|
||||
\(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
|
||||
|
||||
let match1_ = matchN_ 1
|
||||
|
||||
|
|
@ -79,45 +86,46 @@ let mRngYMD =
|
|||
\(r : Natural) ->
|
||||
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 =
|
||||
\(ss : List PartEntry) ->
|
||||
let toEntry =
|
||||
\(x : PartEntry) ->
|
||||
T.FromEntryGetter::{
|
||||
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
||||
, eValue = T.EntryNumGetter.ConstN x._2
|
||||
, eComment = x._3
|
||||
}
|
||||
let partN =
|
||||
\(c : T.EntryCurGetter) ->
|
||||
\(a : T.EntryAcntGetter) ->
|
||||
\(comment : Text) ->
|
||||
\(ss : List PartSplit) ->
|
||||
let toSplit =
|
||||
\(x : PartSplit) ->
|
||||
nullSplit (T.EntryAcntGetter.ConstT x._1) c
|
||||
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
|
||||
, 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 =
|
||||
\(ss : List PartEntry) ->
|
||||
let toEntry =
|
||||
\(x : PartEntry) ->
|
||||
T.ToEntryGetter::{
|
||||
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
||||
, eValue =
|
||||
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
|
||||
, eComment = x._3
|
||||
}
|
||||
let part1 =
|
||||
\(c : T.EntryCurGetter) ->
|
||||
\(a : T.EntryAcntGetter) ->
|
||||
\(comment : Text) ->
|
||||
partN c a comment ([] : List PartSplit)
|
||||
|
||||
in List/map PartEntry T.ToEntryGetter.Type toEntry ss
|
||||
let part1_ =
|
||||
\(c : T.EntryCurGetter) ->
|
||||
\(a : T.EntryAcntGetter) ->
|
||||
partN c a "" ([] : List PartSplit)
|
||||
|
||||
let addDay =
|
||||
\(x : T.GregorianM) ->
|
||||
\(d : Natural) ->
|
||||
{ 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 }
|
||||
|
||||
|
|
@ -127,7 +135,13 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
|
|||
|
||||
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
|
||||
|
||||
in { cron1
|
||||
in { nullSplit
|
||||
, nullMatch
|
||||
, nullVal
|
||||
, nullOpts
|
||||
, nullCron
|
||||
, nullMod
|
||||
, cron1
|
||||
, mY
|
||||
, mYM
|
||||
, mYMD
|
||||
|
|
@ -142,8 +156,9 @@ in { cron1
|
|||
, match1
|
||||
, greg
|
||||
, gregM
|
||||
, partNFrom
|
||||
, partNTo
|
||||
, partN
|
||||
, part1
|
||||
, part1_
|
||||
, addDay
|
||||
, comma = 44
|
||||
, tab = 9
|
||||
|
|
@ -155,8 +170,6 @@ in { cron1
|
|||
, mvDen
|
||||
, mvDenP
|
||||
, mvDenN
|
||||
, PartEntry
|
||||
, nullEntry
|
||||
, nullMod
|
||||
, PartSplit
|
||||
}
|
||||
/\ T
|
||||
|
|
|
|||
|
|
@ -1,419 +0,0 @@
|
|||
module Internal.Budget (readBudgetCRUD) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Decimal hiding (allocate)
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
|
||||
readBudgetCRUD o@CRUDOps {coCreate} = do
|
||||
bs <- mapM readBudget coCreate
|
||||
return $ o {coCreate = bs}
|
||||
|
||||
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
|
||||
readBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
, bgtTransfers
|
||||
, bgtShadowTransfers
|
||||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
, bgtInterval
|
||||
} =
|
||||
do
|
||||
spanRes <- getSpan
|
||||
(bgtLabel,) <$> case spanRes of
|
||||
Nothing -> return []
|
||||
Just budgetSpan -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers c budgetSpan bgtTransfers
|
||||
combineErrorM (concat <$> res1) res2 $ \is ts ->
|
||||
addShadowTransfers bgtShadowTransfers (is ++ ts)
|
||||
where
|
||||
c = CommitR (CommitHash $ hash b) CTBudget
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||
pre_ = sortAllos bgtPretax
|
||||
tax_ = sortAllos bgtTax
|
||||
post_ = sortAllos bgtPosttax
|
||||
sortAllos = liftExcept . mapErrors sortAllo
|
||||
alloAcnts =
|
||||
(alloAcnt <$> bgtPretax)
|
||||
++ (alloAcnt <$> bgtTax)
|
||||
++ (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)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||
return $ a {alloAmts = reverse bs}
|
||||
where
|
||||
foldSpan acc [] = return acc
|
||||
foldSpan acc (x : xs) = do
|
||||
let start = amtWhen x
|
||||
res <- case xs of
|
||||
[] -> resolveDaySpan start
|
||||
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
|
||||
foldSpan (x {amtWhen = res} : acc) xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Income
|
||||
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
readIncome
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> IntAllocations
|
||||
-> DaySpan
|
||||
-> Income
|
||||
-> m [Tx CommitR]
|
||||
readIncome
|
||||
key
|
||||
(intPre, intTax, intPost)
|
||||
ds
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
|
||||
, incPretax
|
||||
, incPosttax
|
||||
, incTaxes
|
||||
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
|
||||
, incGross
|
||||
, incPayPeriod
|
||||
, incPriority
|
||||
} =
|
||||
combineErrorM
|
||||
(combineError incRes nonIncRes (,))
|
||||
(combineError cpRes dayRes (,))
|
||||
$ \_ (cp, days) -> do
|
||||
let gross = realFracToDecimalP (cpPrec cp) incGross
|
||||
foldDays (allocate cp gross) start days
|
||||
where
|
||||
srcAcnt' = AcntID srcAcnt
|
||||
destAcnt' = AcntID destAcnt
|
||||
incRes = isIncomeAcnt srcAcnt'
|
||||
nonIncRes =
|
||||
mapErrors isNotIncomeAcnt $
|
||||
destAcnt'
|
||||
: (alloAcnt <$> incPretax)
|
||||
++ (alloAcnt <$> incTaxes)
|
||||
++ (alloAcnt <$> incPosttax)
|
||||
cpRes = lookupCurrency incCurrency
|
||||
dayRes = liftExcept $ expandDatePat ds incWhen
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
|
||||
allocate cp gross prevDay day = do
|
||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||
let precision = cpPrec cp
|
||||
let (preDeductions, pre) =
|
||||
allocatePre precision gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
let tax =
|
||||
allocateTax precision gross preDeductions scaler $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = gross - sumAllos (tax ++ pre)
|
||||
let post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
|
||||
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
|
||||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||
let primary =
|
||||
EntrySet
|
||||
{ esTotalValue = -gross
|
||||
, esCurrency = cpID cp
|
||||
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
|
||||
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
|
||||
}
|
||||
return $
|
||||
Tx
|
||||
{ txMeta = TxMeta day incPriority (TxDesc "") key
|
||||
, txPrimary = Left primary
|
||||
, txOther = []
|
||||
}
|
||||
|
||||
periodScaler
|
||||
:: PeriodType
|
||||
-> Day
|
||||
-> Day
|
||||
-> AppExcept PeriodScaler
|
||||
periodScaler pt prev cur = return scale
|
||||
where
|
||||
n = workingDays wds prev cur
|
||||
wds = case pt of
|
||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||
Daily ds -> ds
|
||||
scale prec x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* fromIntegral n
|
||||
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
|
||||
|
||||
-- ASSUME start < end
|
||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||
workingDays wds start end = fromIntegral $ daysFull + daysTail
|
||||
where
|
||||
interval = diffDays end start
|
||||
(nFull, nPart) = divMod interval 7
|
||||
daysFull = fromIntegral (length wds') * nFull
|
||||
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
|
||||
startDay = dayOfWeek start
|
||||
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
||||
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
||||
|
||||
-- ASSUME days is a sorted list
|
||||
foldDays
|
||||
:: MonadAppError m
|
||||
=> (Day -> Day -> m a)
|
||||
-> Day
|
||||
-> [Day]
|
||||
-> m [a]
|
||||
foldDays f start days = case NE.nonEmpty days of
|
||||
Nothing -> return []
|
||||
Just ds
|
||||
| any (start >) ds ->
|
||||
throwError $
|
||||
AppException [PeriodError start $ minimum ds]
|
||||
| otherwise ->
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
||||
isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
||||
isIncomeAcnt = checkAcntType IncomeT
|
||||
|
||||
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
||||
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
||||
|
||||
checkAcntType
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = return i
|
||||
| otherwise = throwError $ AppException [AccountTypeError i ts]
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
||||
selectAllos day Allocation {alloAmts, alloTo} =
|
||||
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
|
||||
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
||||
Entry
|
||||
{ eValue = LinkValue (EntryFixed faValue)
|
||||
, eComment = faDesc
|
||||
, eAcnt = AcntID taAcnt
|
||||
, eTags = TagID <$> taTags
|
||||
}
|
||||
|
||||
type PreDeductions = M.Map T.Text Decimal
|
||||
|
||||
allocatePre
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (PreDeductions, [FlatAllocation Decimal])
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
where
|
||||
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
||||
let v =
|
||||
if prePercent
|
||||
then gross *. (preValue / 100)
|
||||
else realFracToDecimalP precision preValue
|
||||
in (mapAdd_ preCategory v m, f {faValue = v})
|
||||
|
||||
allocateTax
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> PreDeductions
|
||||
-> PeriodScaler
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Decimal]
|
||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p -> agi *. p / 100
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
let taxDed = f precision tpDeductible
|
||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||
|
||||
-- | Compute effective tax percentage of a bracket
|
||||
-- The algorithm can be thought of in three phases:
|
||||
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
||||
-- than the bracket limit
|
||||
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
|
||||
-- bracket limit and multiplying by the tax percentage.
|
||||
-- 3. Adding all lower brackets, which are just the limit of the bracket less
|
||||
-- the amount of the lower bracket times the percentage.
|
||||
--
|
||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||
-- three steps are implemented from this alone.
|
||||
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
|
||||
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||
let l = f prec tbLowerLimit
|
||||
in if remain >= l
|
||||
then (acc + (remain - l) *. (tbPercent / 100), l)
|
||||
else a
|
||||
|
||||
allocatePost
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Decimal]
|
||||
allocatePost prec aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent}
|
||||
| postPercent = aftertax *. (postValue / 100)
|
||||
| otherwise = realFracToDecimalP prec postValue
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> [ShadowTransfer]
|
||||
-> [Tx CommitR]
|
||||
-> m [Tx CommitR]
|
||||
addShadowTransfers ms = mapErrors go
|
||||
where
|
||||
go tx = do
|
||||
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
||||
return $ tx {txOther = Right <$> es}
|
||||
|
||||
fromShadow
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> Tx CommitR
|
||||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
|
||||
combineErrorM curRes mRes $ \cur compiled -> do
|
||||
res <- liftExcept $ shadowMatches compiled tx
|
||||
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 $
|
||||
fromRes
|
||||
&& toRes
|
||||
&& maybe True (`dateMatches` txmDate) tmDate
|
||||
&& valRes
|
||||
where
|
||||
fa = either getAcntFrom getAcntFrom txPrimary
|
||||
ta = either getAcntTo getAcntTo txPrimary
|
||||
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
|
||||
|
||||
alloAcnt :: Allocation w v -> AcntID
|
||||
alloAcnt = AcntID . taAcnt . alloTo
|
||||
|
||||
type IntAllocations =
|
||||
( [DaySpanAllocation PretaxValue]
|
||||
, [DaySpanAllocation TaxValue]
|
||||
, [DaySpanAllocation PosttaxValue]
|
||||
)
|
||||
|
||||
type DaySpanAllocation = Allocation DaySpan
|
||||
|
||||
type PeriodScaler = Precision -> Double -> Decimal
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
module Internal.Config
|
||||
( readConfig
|
||||
-- , readYaml
|
||||
)
|
||||
where
|
||||
|
||||
-- import Control.Exception
|
||||
-- import Data.Yaml
|
||||
import Dhall hiding (record)
|
||||
import Internal.Types
|
||||
import RIO
|
||||
|
||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||
readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
|
||||
|
||||
-- readYaml :: FromJSON a => FilePath -> IO a
|
||||
-- readYaml p = do
|
||||
-- r <- decodeFileEither p
|
||||
-- case r of
|
||||
-- Right a -> return a
|
||||
-- Left e -> throw e
|
||||
|
|
@ -1,905 +0,0 @@
|
|||
module Internal.Database
|
||||
( runDB
|
||||
, readDB
|
||||
, nukeTables
|
||||
, updateMeta
|
||||
-- , updateDBState
|
||||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
, indexAcntRoot
|
||||
, paths2IDs
|
||||
, mkPool
|
||||
, insertEntry
|
||||
, readUpdates
|
||||
, updateTx
|
||||
, sync
|
||||
)
|
||||
where
|
||||
|
||||
import Conduit
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Rerunnable
|
||||
import Control.Monad.Logger
|
||||
import Data.Decimal
|
||||
import Data.Hashable
|
||||
import qualified Data.Text.IO as TI
|
||||
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
import Database.Persist.Sqlite hiding
|
||||
( Statement
|
||||
, delete
|
||||
, deleteWhere
|
||||
, insert
|
||||
, insertKey
|
||||
, insert_
|
||||
, runMigration
|
||||
, update
|
||||
, (==.)
|
||||
, (||.)
|
||||
)
|
||||
import Internal.Budget
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
|
||||
sync
|
||||
:: (MonadUnliftIO m, MonadRerunnableIO m)
|
||||
=> ConnectionPool
|
||||
-> FilePath
|
||||
-> Config
|
||||
-> [Budget]
|
||||
-> [History]
|
||||
-> m ()
|
||||
sync pool root c bs hs = do
|
||||
-- _ <- askLoggerIO
|
||||
|
||||
(meta, txState, budgets, history) <- runSqlQueryT pool $ do
|
||||
runMigration migrateAll
|
||||
liftIOExceptT $ readDB c bs hs
|
||||
|
||||
-- Read raw transactions according to state. If a transaction is already in
|
||||
-- the database, don't read it but record the commit so we can update it.
|
||||
(budgets', history') <-
|
||||
flip runReaderT txState $ do
|
||||
-- TODO collect errors here
|
||||
b <- liftIOExceptT $ readBudgetCRUD budgets
|
||||
h <- readHistoryCRUD root history
|
||||
return (b, h)
|
||||
liftIO $ TI.putStr $ formatBuildPlan history budgets
|
||||
|
||||
-- Update the DB.
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
|
||||
-- NOTE this must come first (unless we defer foreign keys)
|
||||
updateMeta meta
|
||||
res <- runExceptT $ do
|
||||
-- TODO multithread this :)
|
||||
insertBudgets budgets'
|
||||
insertHistory history'
|
||||
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||
-- whatever error is encountered above in an IO context, but the first
|
||||
-- thrown error should be caught despite possibly needing to be rerun
|
||||
rerunnableIO $ fromEither res
|
||||
|
||||
formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
|
||||
formatBuildPlan
|
||||
CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
|
||||
CRUDOps {coCreate = bc, coDelete = bd} =
|
||||
T.unlines $ "Build plan:" : (T.append " " <$> ht ++ [""] ++ bt)
|
||||
where
|
||||
ht =
|
||||
[ T.append "History transfers to create: " $ tshow hCt
|
||||
, T.append "History statements to create: " $ tshow hCs
|
||||
, T.append "History entries to read: " $ tshow $ length hr
|
||||
, T.append "History entry sets to update: " $ tshow $ length hu
|
||||
]
|
||||
++ formatDel "History" hd
|
||||
bt =
|
||||
T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
|
||||
: formatDel "Budget" bd
|
||||
toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
|
||||
formatDel what (DeleteTxs e a b c' d) =
|
||||
[ f "commits" e
|
||||
, f "transactions" a
|
||||
, f "entry sets" b
|
||||
, f "entries" c'
|
||||
, f "tag relations" d
|
||||
]
|
||||
where
|
||||
f :: T.Text -> [a] -> T.Text
|
||||
f thing = toDel what thing . length
|
||||
(hCt, hCs) = bimap length length hc
|
||||
|
||||
runDB
|
||||
:: MonadUnliftIO m
|
||||
=> SqlConfig
|
||||
-> SqlQueryT (NoLoggingT m) a
|
||||
-> m a
|
||||
runDB c more =
|
||||
runNoLoggingT $ do
|
||||
pool <- mkPool c
|
||||
runSqlQueryT pool $ do
|
||||
_ <- lift askLoggerIO
|
||||
runMigration migrateAll
|
||||
more
|
||||
|
||||
mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
|
||||
mkPool c = case c of
|
||||
Sqlite p -> createSqlitePool p 10
|
||||
-- conn <- open p
|
||||
-- wrapConnection conn logfn
|
||||
Postgres -> error "postgres not implemented"
|
||||
|
||||
nukeTables :: MonadSqlQuery m => m ()
|
||||
nukeTables = do
|
||||
deleteWhere ([] :: [Filter CommitR])
|
||||
deleteWhere ([] :: [Filter CurrencyR])
|
||||
deleteWhere ([] :: [Filter AccountR])
|
||||
deleteWhere ([] :: [Filter TransactionR])
|
||||
|
||||
-- showBalances :: MonadUnliftIO m => SqlPersistT m ()
|
||||
-- showBalances = do
|
||||
-- xs <- select $ do
|
||||
-- (accounts :& splits :& txs) <-
|
||||
-- from
|
||||
-- $ table @AccountR
|
||||
-- `innerJoin` table @SplitR
|
||||
-- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
|
||||
-- `innerJoin` table @TransactionR
|
||||
-- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
|
||||
-- where_ $
|
||||
-- isNothing (txs ^. TransactionRBucket)
|
||||
-- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
|
||||
-- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
|
||||
-- )
|
||||
-- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
|
||||
-- return
|
||||
-- ( accounts ^. AccountRFullpath
|
||||
-- , accounts ^. AccountRName
|
||||
-- , sum_ $ splits ^. SplitRValue
|
||||
-- )
|
||||
-- -- TODO super stetchy table printing thingy
|
||||
-- liftIO $ do
|
||||
-- putStrLn $ T.unpack $ fmt "Account" "Balance"
|
||||
-- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
|
||||
-- mapM_ (putStrLn . T.unpack . fmtBalance) xs
|
||||
-- where
|
||||
-- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
|
||||
-- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
|
||||
-- pad n xs = T.append xs $ T.replicate (n - T.length xs) " "
|
||||
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
||||
-- toBal = maybe "???" (fmtRational 2) . unValue
|
||||
|
||||
readDB
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> Config
|
||||
-> [Budget]
|
||||
-> [History]
|
||||
-> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
|
||||
readDB c bs hs = do
|
||||
curAcnts <- readCurrentIds
|
||||
curPaths <- readCurrentIds
|
||||
curCurs <- readCurrentIds
|
||||
curTags <- readCurrentIds
|
||||
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
|
||||
let bsRes = BudgetSpan <$> resolveScope budgetInterval
|
||||
let hsRes = HistorySpan <$> resolveScope statementInterval
|
||||
combineErrorM bsRes hsRes $ \bscope hscope -> do
|
||||
-- ASSUME the db must be empty if these are empty
|
||||
let dbempty = null curAcnts && null curCurs && null curTags
|
||||
let meta =
|
||||
MetaCRUD
|
||||
{ mcCurrencies = makeCD newCurs curCurs
|
||||
, mcTags = makeCD newTags curTags
|
||||
, mcAccounts = makeCD newAcnts curAcnts
|
||||
, mcPaths = makeCD newPaths curPaths
|
||||
, mcBudgetScope = bscope
|
||||
, mcHistoryScope = hscope
|
||||
}
|
||||
let txS =
|
||||
TxState
|
||||
{ tsAccountMap = amap
|
||||
, tsCurrencyMap = cmap
|
||||
, tsTagMap = tmap
|
||||
, tsBudgetScope = bscope
|
||||
, tsHistoryScope = hscope
|
||||
}
|
||||
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
|
||||
budgets <- makeBudgetCRUD existing bs curBgts bChanged
|
||||
history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
|
||||
return (meta, txS, budgets, history)
|
||||
where
|
||||
(ts, ss) = splitHistory hs
|
||||
makeCD new old =
|
||||
let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
|
||||
in CRUDOps cs () () ds
|
||||
(newAcnts, newPaths) = indexAcntRoot $ accounts c
|
||||
newTags = tag2Record <$> tags c
|
||||
newCurs = currency2Record <$> currencies c
|
||||
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
||||
amap = makeAcntMap newAcnts
|
||||
cmap = currencyMap newCurs
|
||||
tmap = makeTagMap newTags
|
||||
fromMap f = S.fromList . fmap f . M.elems
|
||||
existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
|
||||
|
||||
makeBudgetCRUD
|
||||
:: MonadSqlQuery m
|
||||
=> ExistingConfig
|
||||
-> [Budget]
|
||||
-> [CommitHash]
|
||||
-> Bool
|
||||
-> m (CRUDOps [Budget] () () DeleteTxs)
|
||||
makeBudgetCRUD existing new old scopeChanged = do
|
||||
(toIns, toDel) <-
|
||||
if scopeChanged
|
||||
then (new,) <$> readTxIds old
|
||||
else do
|
||||
let (toDelHashes, overlap, toIns) = setDiffHashes old new
|
||||
toDel <- readTxIds toDelHashes
|
||||
(toInsRetry, _) <- readInvalidIds existing overlap
|
||||
return (toIns ++ (snd <$> toInsRetry), toDel)
|
||||
return $ CRUDOps toIns () () toDel
|
||||
|
||||
makeStatementCRUD
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> ExistingConfig
|
||||
-> ([PairedTransfer], [CommitHash])
|
||||
-> ([Statement], [CommitHash])
|
||||
-> Bool
|
||||
-> m
|
||||
( CRUDOps
|
||||
([PairedTransfer], [Statement])
|
||||
[ReadEntry]
|
||||
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||
DeleteTxs
|
||||
)
|
||||
makeStatementCRUD existing ts ss scopeChanged = do
|
||||
(toInsTs, toDelTs, validTs) <- uncurry diff ts
|
||||
(toInsSs, toDelSs, validSs) <- uncurry diff ss
|
||||
let toDelAllHashes = toDelTs ++ toDelSs
|
||||
-- If we are inserting or deleting something or the scope changed, pull out
|
||||
-- the remainder of the entries to update/read as we are (re)inserting other
|
||||
-- stuff (this is necessary because a given transaction may depend on the
|
||||
-- value of previous transactions, even if they are already in the DB).
|
||||
(toRead, toUpdate) <- case (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
|
||||
([], [], [], False) -> return ([], [])
|
||||
_ -> readUpdates $ validTs ++ validSs
|
||||
toDelAll <- readTxIds toDelAllHashes
|
||||
return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
|
||||
where
|
||||
diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
|
||||
diff new old = do
|
||||
let (toDelHashes, overlap, toIns) = setDiffHashes old new
|
||||
-- Check the overlap for rows with accounts/tags/currencies that
|
||||
-- won't exist on the next update. Those with invalid IDs will be set aside
|
||||
-- to delete and reinsert (which may also fail) later
|
||||
(invalid, valid) <- readInvalidIds existing overlap
|
||||
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
|
||||
return (toInsAll, toDelAllHashes, valid)
|
||||
|
||||
setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
|
||||
setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
|
||||
|
||||
readScopeChanged
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> Bool
|
||||
-> BudgetSpan
|
||||
-> HistorySpan
|
||||
-> m (Bool, Bool)
|
||||
readScopeChanged dbempty bscope hscope = do
|
||||
rs <- dumpTbl
|
||||
-- TODO these errors should only fire when someone messed with the DB
|
||||
case rs of
|
||||
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
|
||||
[r] -> do
|
||||
let (ConfigStateR h b) = E.entityVal r
|
||||
return (bscope /= b, hscope /= h)
|
||||
_ -> throwAppError $ DBError DBMultiScope
|
||||
|
||||
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
||||
readTxIds cs = do
|
||||
xs <- selectE $ do
|
||||
(commits :& txs :& ess :& es :& ts) <-
|
||||
E.from
|
||||
$ E.table
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||
`E.leftJoin` E.table
|
||||
`E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
|
||||
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
|
||||
return
|
||||
( commits ^. CommitRId
|
||||
, txs ^. TransactionRId
|
||||
, ess ^. EntrySetRId
|
||||
, es ^. EntryRId
|
||||
, ts ?. TagRelationRId
|
||||
)
|
||||
let (cms, txs, ss, es, ts) = L.unzip5 xs
|
||||
return $
|
||||
DeleteTxs
|
||||
{ dtCommits = go cms
|
||||
, dtTxs = go txs
|
||||
, dtEntrySets = go ss
|
||||
, dtEntries = go es
|
||||
, dtTagRelations = catMaybes $ E.unValue <$> ts
|
||||
}
|
||||
where
|
||||
go :: Eq a => [E.Value a] -> [a]
|
||||
go = fmap (E.unValue . NE.head) . NE.group
|
||||
|
||||
makeTagMap :: [Entity TagR] -> TagMap
|
||||
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||
|
||||
tag2Record :: Tag -> Entity TagR
|
||||
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
|
||||
|
||||
currency2Record :: Currency -> Entity CurrencyR
|
||||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
|
||||
|
||||
readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
|
||||
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||
rs <- E.from E.table
|
||||
return (rs ^. E.persistIdField)
|
||||
|
||||
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
||||
readCurrentCommits = do
|
||||
xs <- selectE $ do
|
||||
commits <- E.from E.table
|
||||
return (commits ^. CommitRHash, commits ^. CommitRType)
|
||||
return $ foldr go ([], [], []) xs
|
||||
where
|
||||
go (x, t) (bs, ts, hs) =
|
||||
let y = E.unValue x
|
||||
in case E.unValue t of
|
||||
CTBudget -> (y : bs, ts, hs)
|
||||
CTHistoryTransfer -> (bs, y : ts, hs)
|
||||
CTHistoryStatement -> (bs, ts, y : hs)
|
||||
|
||||
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
|
||||
setDiffWith f = go [] []
|
||||
where
|
||||
go inA inBoth [] bs = (inA, inBoth, bs)
|
||||
go inA inBoth as [] = (as ++ inA, inBoth, [])
|
||||
go inA inBoth (a : as) bs =
|
||||
let (res, bs') = findDelete (f a) bs
|
||||
in case res of
|
||||
Nothing -> go (a : inA) inBoth as bs
|
||||
Just b -> go inA ((a, b) : inBoth) as bs'
|
||||
|
||||
findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
|
||||
findDelete f xs = case break f xs of
|
||||
(ys, []) -> (Nothing, ys)
|
||||
(ys, z : zs) -> (Just z, ys ++ zs)
|
||||
|
||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||
dumpTbl = selectE $ E.from E.table
|
||||
|
||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||
currencyMap =
|
||||
M.fromList
|
||||
. fmap
|
||||
( \e ->
|
||||
( currencyRSymbol $ entityVal e
|
||||
, CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
|
||||
)
|
||||
)
|
||||
|
||||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||
toKey = toSqlKey . fromIntegral . hash
|
||||
|
||||
makeAccountEntity :: AccountR -> Entity AccountR
|
||||
makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
|
||||
|
||||
makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
|
||||
makeAccountR atype name parents des = AccountR name path des (accountSign atype)
|
||||
where
|
||||
path = AcntPath atype (reverse $ name : parents)
|
||||
|
||||
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
|
||||
tree2Records t = go []
|
||||
where
|
||||
go ps (Placeholder d n cs) =
|
||||
let (parentKeys, parentNames) = L.unzip ps
|
||||
a = acnt n parentNames d False
|
||||
k = entityKey a
|
||||
thesePaths = expand k parentKeys
|
||||
in bimap ((a :) . concat) ((thesePaths ++) . concat) $
|
||||
L.unzip $
|
||||
go ((k, n) : ps) <$> cs
|
||||
go ps (Account d n) =
|
||||
let (parentKeys, parentNames) = L.unzip ps
|
||||
a = acnt n parentNames d True
|
||||
k = entityKey a
|
||||
in ([a], expand k parentKeys)
|
||||
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
|
||||
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
|
||||
|
||||
accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
|
||||
accountPathRecord p c d =
|
||||
Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
|
||||
|
||||
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
||||
paths2IDs =
|
||||
uncurry zip
|
||||
. first trimNames
|
||||
. L.unzip
|
||||
. L.sortOn fst
|
||||
. fmap (first (NE.reverse . acntPath2NonEmpty))
|
||||
|
||||
-- none of these errors should fire assuming that input is sorted and unique
|
||||
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
||||
trimNames = fmap (AcntID . T.intercalate "_") . go []
|
||||
where
|
||||
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
||||
go prev = concatMap (go' prev) . groupNonEmpty
|
||||
go' prev (key, rest) = case rest of
|
||||
(_ :| []) -> [key : prev]
|
||||
([] :| xs) ->
|
||||
let next = key : prev
|
||||
other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
|
||||
in next : other
|
||||
(x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
|
||||
err = error "account path list either not sorted or contains duplicates"
|
||||
|
||||
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
|
||||
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
|
||||
|
||||
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
||||
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
||||
((IncomeT,) <$> arIncome)
|
||||
++ ((ExpenseT,) <$> arExpenses)
|
||||
++ ((LiabilityT,) <$> arLiabilities)
|
||||
++ ((AssetT,) <$> arAssets)
|
||||
++ ((EquityT,) <$> arEquity)
|
||||
|
||||
makeAcntMap :: [Entity AccountR] -> AccountMap
|
||||
makeAcntMap =
|
||||
M.fromList
|
||||
. paths2IDs
|
||||
. fmap go
|
||||
. filter (accountRLeaf . snd)
|
||||
. fmap (\e -> (E.entityKey e, E.entityVal e))
|
||||
where
|
||||
go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
|
||||
|
||||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
||||
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
||||
|
||||
updateCD
|
||||
:: ( MonadSqlQuery m
|
||||
, PersistRecordBackend a SqlBackend
|
||||
)
|
||||
=> EntityCRUDOps a
|
||||
-> m ()
|
||||
updateCD (CRUDOps cs () () ds) = do
|
||||
mapM_ deleteKeyE ds
|
||||
insertEntityManyE cs
|
||||
|
||||
-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
|
||||
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
|
||||
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
|
||||
mapM_ deleteKeyE dtTagRelations
|
||||
mapM_ deleteKeyE dtEntries
|
||||
mapM_ deleteKeyE dtEntrySets
|
||||
mapM_ deleteKeyE dtTxs
|
||||
mapM_ deleteKeyE dtCommits
|
||||
|
||||
-- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
-- updateDBState = do
|
||||
-- updateCD =<< asks csCurrencies
|
||||
-- updateCD =<< asks csAccounts
|
||||
-- updateCD =<< asks csPaths
|
||||
-- updateCD =<< asks csTags
|
||||
-- -- deleteTxs =<< asks (coDelete . csBudgets)
|
||||
-- -- deleteTxs =<< asks (coDelete . csHistory)
|
||||
-- b <- asks csBudgetScope
|
||||
-- h <- asks csHistoryScope
|
||||
-- repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
||||
|
||||
updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
|
||||
updateMeta
|
||||
MetaCRUD
|
||||
{ mcCurrencies
|
||||
, mcAccounts
|
||||
, mcPaths
|
||||
, mcTags
|
||||
, mcBudgetScope
|
||||
, mcHistoryScope
|
||||
} = do
|
||||
updateCD mcCurrencies
|
||||
updateCD mcAccounts
|
||||
updateCD mcPaths
|
||||
updateCD mcTags
|
||||
repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
|
||||
|
||||
readInvalidIds
|
||||
:: MonadSqlQuery m
|
||||
=> ExistingConfig
|
||||
-> [(CommitHash, a)]
|
||||
-> m ([(CommitHash, a)], [CommitHash])
|
||||
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||
rs <- selectE $ do
|
||||
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||
E.from
|
||||
$ E.table
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||
`E.innerJoin` E.table
|
||||
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||
`E.leftJoin` E.table
|
||||
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
|
||||
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
|
||||
return
|
||||
( commits ^. CommitRHash
|
||||
, entrysets ^. EntrySetRCurrency
|
||||
, entries ^. EntryRAccount
|
||||
, tags ?. TagRelationRTag
|
||||
)
|
||||
-- TODO there are faster ways to do this; may/may not matter
|
||||
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
||||
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
||||
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
||||
let invalid = (cs `S.union` as) `S.union` ts
|
||||
return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
|
||||
where
|
||||
go existing =
|
||||
S.fromList
|
||||
. fmap (E.unValue . fst)
|
||||
. L.filter (not . all (`S.member` existing) . snd)
|
||||
. groupKey id
|
||||
|
||||
readUpdates
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> [CommitHash]
|
||||
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||
readUpdates hashes = do
|
||||
xs <- selectE $ do
|
||||
(commits :& txs :& entrysets :& entries :& currencies) <-
|
||||
E.from
|
||||
$ E.table @CommitR
|
||||
`E.innerJoin` E.table @TransactionR
|
||||
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||
`E.innerJoin` E.table @EntrySetR
|
||||
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||
`E.innerJoin` E.table @EntryR
|
||||
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||
`E.innerJoin` E.table @CurrencyR
|
||||
`E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
|
||||
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
|
||||
return
|
||||
( entrysets ^. EntrySetRRebalance
|
||||
,
|
||||
(
|
||||
( entrysets ^. EntrySetRId
|
||||
, entrysets ^. EntrySetRIndex
|
||||
, txs ^. TransactionRDate
|
||||
, txs ^. TransactionRPriority
|
||||
, txs ^. TransactionRDescription
|
||||
,
|
||||
( entrysets ^. EntrySetRCurrency
|
||||
, currencies ^. CurrencyRPrecision
|
||||
)
|
||||
)
|
||||
, entries
|
||||
)
|
||||
)
|
||||
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
||||
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
|
||||
let toRead' = fmap (makeRE . snd) toRead
|
||||
return (toRead', toUpdate')
|
||||
where
|
||||
makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
|
||||
let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
|
||||
let prec' = fromIntegral $ E.unValue prec
|
||||
let cur = E.unValue curID
|
||||
let res =
|
||||
bimap NE.nonEmpty NE.nonEmpty $
|
||||
NE.partition ((< 0) . entryRIndex . snd) $
|
||||
NE.sortWith (entryRIndex . snd) $
|
||||
fmap (\e -> (entityKey e, entityVal e)) es
|
||||
case res of
|
||||
(Just froms, Just tos) -> do
|
||||
let tot = sum $ fmap (entryRValue . snd) froms
|
||||
(from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
|
||||
(from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
|
||||
-- TODO WAP (wet ass programming)
|
||||
return $ case from0' of
|
||||
Left x ->
|
||||
Left $
|
||||
UpdateEntrySet
|
||||
{ utCurrency = cur
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
, utToRO = toRO
|
||||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = realFracToDecimalP prec' tot
|
||||
, utSortKey = sk
|
||||
, utIndex = E.unValue esi
|
||||
}
|
||||
Right x ->
|
||||
Right $
|
||||
UpdateEntrySet
|
||||
{ utCurrency = cur
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
, utToRO = toRO
|
||||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = ()
|
||||
, utSortKey = sk
|
||||
, utIndex = E.unValue esi
|
||||
}
|
||||
-- TODO this error is lame
|
||||
_ -> throwAppError $ DBError DBUpdateUnbalanced
|
||||
makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
|
||||
let e = entityVal entry
|
||||
in ReadEntry
|
||||
{ reCurrency = E.unValue curID
|
||||
, reAcnt = entryRAccount e
|
||||
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
||||
, reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
|
||||
, reESIndex = E.unValue esi
|
||||
, reIndex = entryRIndex e
|
||||
}
|
||||
|
||||
splitFrom
|
||||
:: Precision
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||
splitFrom prec (f0 :| fs) = do
|
||||
-- ASSUME entries are sorted by index
|
||||
-- TODO combine errors here
|
||||
let f0Res = readDeferredValue prec f0
|
||||
let fsRes = mapErrors (splitDeferredValue prec) fs
|
||||
combineErrorM f0Res fsRes $ \f0' fs' -> do
|
||||
let (ro, unk) = partitionEithers fs'
|
||||
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
|
||||
return (f0', ro, unk)
|
||||
|
||||
splitTo
|
||||
:: Precision
|
||||
-> Either UEBlank (Either UE_RO UEUnk)
|
||||
-> [UEUnk]
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> AppExcept
|
||||
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
||||
, [(UEUnk, [UELink])]
|
||||
, UEBlank
|
||||
, [UE_RO]
|
||||
, [UEUnk]
|
||||
)
|
||||
splitTo prec from0 fromUnk (t0 :| ts) = do
|
||||
-- How to split the credit side of the database transaction in 1024 easy
|
||||
-- steps:
|
||||
--
|
||||
-- 1. Split incoming entries (except primary) into those with links and not
|
||||
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
|
||||
|
||||
-- 2. For unlinked entries, split into read-only and unknown entries
|
||||
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
|
||||
|
||||
-- 3. For linked entries, split into those that link to the primary debit
|
||||
-- entry and not
|
||||
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
||||
|
||||
-- 4. For linked entries that don't link to the primary debit entry, split
|
||||
-- into those that link to an unknown debit entry or not. Those that
|
||||
-- are not will be read-only and those that are will be collected with
|
||||
-- their linked debit entry
|
||||
let linkedRes = zipPaired prec fromUnk linkedN
|
||||
|
||||
-- 5. For entries linked to the primary debit entry, turn them into linked
|
||||
-- entries (lazily only used when needed later)
|
||||
let from0Res = mapErrors (makeLinkUnk . snd) linked0
|
||||
|
||||
combineErrorM3 from0Res linkedRes unlinkedRes $
|
||||
-- 6. Depending on the type of primary debit entry we have, add linked
|
||||
-- entries if it is either an unknown or a blank (to be solved) entry,
|
||||
-- or turn the remaining linked entries to read-only and add to the other
|
||||
-- read-only entries
|
||||
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
|
||||
let (from0', toROLinked0) = case from0 of
|
||||
Left blnk -> (Left (blnk, from0Links), [])
|
||||
Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
|
||||
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
|
||||
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
|
||||
where
|
||||
primary = uncurry makeUnkUE t0
|
||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
||||
|
||||
-- | Match linked credit entries with unknown entries, returning a list of
|
||||
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
|
||||
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
|
||||
-- sorted.
|
||||
zipPaired
|
||||
:: Precision
|
||||
-> [UEUnk]
|
||||
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
|
||||
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||
zipPaired prec = go ([], [])
|
||||
where
|
||||
nolinks = ((,[]) <$>)
|
||||
go acc fs [] = return $ first (nolinks fs ++) acc
|
||||
go (facc, tacc) fs ((ti, tls) : ts) = do
|
||||
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
|
||||
links <- NE.toList <$> mapErrors makeLinkUnk tls
|
||||
let (nextLink, fs') = case rest of
|
||||
(r0 : rs)
|
||||
| ueIndex r0 == ti -> (Just (r0, links), rs)
|
||||
| otherwise -> (Nothing, rest)
|
||||
_ -> (Nothing, rest)
|
||||
let acc' = (nolinks lesser ++ facc, tacc)
|
||||
let ros = NE.toList $ makeRoUE prec . snd <$> tls
|
||||
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
||||
go (f acc') fs' ts
|
||||
|
||||
makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
|
||||
makeLinkUnk (k, e) =
|
||||
-- TODO error should state that scale must be present for a link in the db
|
||||
maybe
|
||||
(throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ fromRational <$> entryRCachedValue e
|
||||
|
||||
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
|
||||
splitDeferredValue prec p@(k, _) = do
|
||||
res <- readDeferredValue prec p
|
||||
case res of
|
||||
Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
|
||||
Right x -> return x
|
||||
|
||||
readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
||||
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
|
||||
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
|
||||
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
|
||||
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
||||
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
||||
(Nothing, Just TBalance) -> err DBLinkInvalidBalance
|
||||
(Nothing, Just TPercent) -> err DBLinkInvalidPercent
|
||||
where
|
||||
go = return . Right . Right
|
||||
err = throwAppError . DBError . DBLinkError k
|
||||
|
||||
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
||||
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||
|
||||
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
|
||||
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
|
||||
|
||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||
makeUnkUE k e = makeUE k e ()
|
||||
|
||||
-- updateEntries
|
||||
-- :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
|
||||
-- => [ ( BudgetName
|
||||
-- , CRUDOps
|
||||
-- [Tx CommitR]
|
||||
-- [ReadEntry]
|
||||
-- [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
|
||||
-- DeleteTxs
|
||||
-- )
|
||||
-- ]
|
||||
-- -> m ()
|
||||
-- updateEntries es = do
|
||||
-- res <- runExceptT $ mapErrors (uncurry insertAll) es
|
||||
-- void $ rerunnableIO $ fromEither res
|
||||
|
||||
insertBudgets
|
||||
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> FinalBudgetCRUD
|
||||
-> m ()
|
||||
insertBudgets (CRUDOps bs () () ds) = do
|
||||
deleteTxs ds
|
||||
mapM_ go bs
|
||||
where
|
||||
go (name, cs) = do
|
||||
-- TODO useless overhead?
|
||||
(toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
|
||||
mapM_ updateTx toUpdate
|
||||
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
|
||||
\(c, ts) -> do
|
||||
ck <- insert c
|
||||
mapM_ (insertTx name ck) ts
|
||||
|
||||
insertHistory
|
||||
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> FinalHistoryCRUD
|
||||
-> m ()
|
||||
insertHistory (CRUDOps cs rs us ds) = do
|
||||
(toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
|
||||
mapM_ updateTx toUpdate
|
||||
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
|
||||
\(c, ts) -> do
|
||||
ck <- insert c
|
||||
mapM_ (insertTx historyName ck) ts
|
||||
deleteTxs ds
|
||||
|
||||
-- insertAll
|
||||
-- :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||
-- => BudgetName
|
||||
-- -> CRUDOps
|
||||
-- [Tx CommitR]
|
||||
-- [ReadEntry]
|
||||
-- [Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||
-- DeleteTxs
|
||||
-- -> m ()
|
||||
-- insertAll b (CRUDOps cs rs us ds) = do
|
||||
-- (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
|
||||
-- mapM_ updateTx toUpdate
|
||||
-- forM_ (groupWith itxCommit toInsert) $
|
||||
-- \(c, ts) -> do
|
||||
-- ck <- insert c
|
||||
-- mapM_ (insertTx b ck) ts
|
||||
-- deleteTxs ds
|
||||
|
||||
insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
|
||||
insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
|
||||
k <- insert $ TransactionR c txmDate b txmDesc txmPriority
|
||||
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
||||
where
|
||||
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
||||
let fs = NE.toList iesFromEntries
|
||||
let ts = NE.toList iesToEntries
|
||||
let rebalance = any (isJust . ieCached) (fs ++ ts)
|
||||
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
||||
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
||||
go k i e = void $ insertEntry k i e
|
||||
|
||||
insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
|
||||
insertEntry
|
||||
k
|
||||
i
|
||||
InsertEntry
|
||||
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
||||
, ieCached
|
||||
} =
|
||||
do
|
||||
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
||||
mapM_ (insert_ . TagRelationR ek) eTags
|
||||
return ek
|
||||
where
|
||||
(cval, ctype, deflink) = case ieCached of
|
||||
(Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
|
||||
(Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
||||
(Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
||||
Nothing -> (Nothing, Just TFixed, Nothing)
|
||||
|
||||
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
||||
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
||||
where
|
||||
v = toRational $ unStaticValue ueValue
|
||||
|
||||
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
|
||||
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
|
||||
|
||||
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||
|
||||
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
|
||||
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
|
||||
|
||||
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
||||
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|
||||
|
||||
historyName :: BudgetName
|
||||
historyName = BudgetName "history"
|
||||
|
|
@ -0,0 +1,366 @@
|
|||
module Internal.Database.Ops
|
||||
( runDB
|
||||
, nukeTables
|
||||
, updateHashes
|
||||
, updateDBState
|
||||
, getDBState
|
||||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
, paths2IDs
|
||||
, mkPool
|
||||
)
|
||||
where
|
||||
|
||||
import Conduit
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Logger
|
||||
import Data.Hashable
|
||||
import Database.Esqueleto.Experimental ((==.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
|
||||
import GHC.Err
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import RIO.List ((\\))
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as N
|
||||
import qualified RIO.Text as T
|
||||
|
||||
runDB
|
||||
:: MonadUnliftIO m
|
||||
=> SqlConfig
|
||||
-> SqlQueryT (NoLoggingT m) a
|
||||
-> m a
|
||||
runDB c more =
|
||||
runNoLoggingT $ do
|
||||
pool <- mkPool c
|
||||
runSqlQueryT pool $ do
|
||||
_ <- lift askLoggerIO
|
||||
runMigration migrateAll
|
||||
more
|
||||
|
||||
mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
|
||||
mkPool c = case c of
|
||||
Sqlite p -> createSqlitePool p 10
|
||||
-- conn <- open p
|
||||
-- wrapConnection conn logfn
|
||||
Postgres -> error "postgres not implemented"
|
||||
|
||||
nukeTables :: MonadSqlQuery m => m ()
|
||||
nukeTables = do
|
||||
deleteWhere ([] :: [Filter CommitR])
|
||||
deleteWhere ([] :: [Filter CurrencyR])
|
||||
deleteWhere ([] :: [Filter AccountR])
|
||||
deleteWhere ([] :: [Filter TransactionR])
|
||||
|
||||
-- showBalances :: MonadUnliftIO m => SqlPersistT m ()
|
||||
-- showBalances = do
|
||||
-- xs <- select $ do
|
||||
-- (accounts :& splits :& txs) <-
|
||||
-- from
|
||||
-- $ table @AccountR
|
||||
-- `innerJoin` table @SplitR
|
||||
-- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
|
||||
-- `innerJoin` table @TransactionR
|
||||
-- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
|
||||
-- where_ $
|
||||
-- isNothing (txs ^. TransactionRBucket)
|
||||
-- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
|
||||
-- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
|
||||
-- )
|
||||
-- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
|
||||
-- return
|
||||
-- ( accounts ^. AccountRFullpath
|
||||
-- , accounts ^. AccountRName
|
||||
-- , sum_ $ splits ^. SplitRValue
|
||||
-- )
|
||||
-- -- TODO super stetchy table printing thingy
|
||||
-- liftIO $ do
|
||||
-- putStrLn $ T.unpack $ fmt "Account" "Balance"
|
||||
-- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
|
||||
-- mapM_ (putStrLn . T.unpack . fmtBalance) xs
|
||||
-- where
|
||||
-- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
|
||||
-- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
|
||||
-- pad n xs = T.append xs $ T.replicate (n - T.length xs) " "
|
||||
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
||||
-- toBal = maybe "???" (fmtRational 2) . unValue
|
||||
|
||||
hashConfig :: Config -> [Int]
|
||||
hashConfig
|
||||
Config_
|
||||
{ budget = bs
|
||||
, statements = ss
|
||||
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
where
|
||||
(ms, ps) = partitionEithers $ fmap go ss
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
-- setDiff = setDiff' (==)
|
||||
setDiff as bs = (as \\ bs, bs \\ as)
|
||||
|
||||
-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
||||
-- setDiff' f = go []
|
||||
-- where
|
||||
-- go inA [] bs = (inA, bs)
|
||||
-- go inA as [] = (as ++ inA, [])
|
||||
-- go inA (a:as) bs = case inB a bs of
|
||||
-- Just bs' -> go inA as bs'
|
||||
-- Nothing -> go (a:inA) as bs
|
||||
-- inB _ [] = Nothing
|
||||
-- inB a (b:bs)
|
||||
-- | f a b = Just bs
|
||||
-- | otherwise = inB a bs
|
||||
|
||||
getDBHashes :: MonadSqlQuery m => m [Int]
|
||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
|
||||
nukeDBHash :: MonadSqlQuery m => Int -> m ()
|
||||
nukeDBHash h = deleteE $ do
|
||||
c <- E.from E.table
|
||||
E.where_ (c ^. CommitRHash ==. E.val h)
|
||||
|
||||
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
|
||||
nukeDBHashes = mapM_ nukeDBHash
|
||||
|
||||
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
|
||||
getConfigHashes c = do
|
||||
let ch = hashConfig c
|
||||
dh <- getDBHashes
|
||||
return $ setDiff dh ch
|
||||
|
||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||
dumpTbl = selectE $ E.from E.table
|
||||
|
||||
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
|
||||
deleteAccount e = deleteE $ do
|
||||
c <- E.from $ E.table @AccountR
|
||||
E.where_ (c ^. AccountRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
|
||||
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
|
||||
deleteCurrency e = deleteE $ do
|
||||
c <- E.from $ E.table @CurrencyR
|
||||
E.where_ (c ^. CurrencyRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
|
||||
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
|
||||
deleteTag e = deleteE $ do
|
||||
c <- E.from $ E.table @TagR
|
||||
E.where_ (c ^. TagRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
|
||||
-- TODO slip-n-slide code...
|
||||
insertFull
|
||||
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
|
||||
=> Entity r
|
||||
-> m ()
|
||||
insertFull (Entity k v) = insertKey k v
|
||||
|
||||
currency2Record :: Currency -> Entity CurrencyR
|
||||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
|
||||
|
||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||
currencyMap =
|
||||
M.fromList
|
||||
. fmap
|
||||
( \e ->
|
||||
( currencyRSymbol $ entityVal e
|
||||
, (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
|
||||
)
|
||||
)
|
||||
|
||||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||
toKey = toSqlKey . fromIntegral . hash
|
||||
|
||||
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
||||
tree2Entity t parents name des =
|
||||
Entity (toSqlKey $ fromIntegral h) $
|
||||
AccountR name (toPath parents) des
|
||||
where
|
||||
p = AcntPath t (reverse (name : parents))
|
||||
h = hash p
|
||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
||||
|
||||
tree2Records
|
||||
:: AcntType
|
||||
-> AccountTree
|
||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
|
||||
tree2Records t = go []
|
||||
where
|
||||
go ps (Placeholder d n cs) =
|
||||
let e = tree2Entity t (fmap snd ps) n d
|
||||
k = entityKey e
|
||||
(as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
|
||||
a0 = acnt k n (fmap snd ps) d
|
||||
paths = expand k $ fmap fst ps
|
||||
in (a0 : concat as, paths ++ concat aps, concat ms)
|
||||
go ps (Account d n) =
|
||||
let e = tree2Entity t (fmap snd ps) n d
|
||||
k = entityKey e
|
||||
in ( [acnt k n (fmap snd ps) d]
|
||||
, expand k $ fmap fst ps
|
||||
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
|
||||
)
|
||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
||||
acnt k n ps = Entity k . AccountR n (toPath ps)
|
||||
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
|
||||
sign = accountSign t
|
||||
|
||||
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
||||
paths2IDs =
|
||||
uncurry zip
|
||||
. first trimNames
|
||||
. L.unzip
|
||||
. L.sortOn fst
|
||||
. fmap (first pathList)
|
||||
where
|
||||
pathList (AcntPath t []) = atName t :| []
|
||||
pathList (AcntPath t ns) = N.reverse $ atName t :| ns
|
||||
|
||||
-- none of these errors should fire assuming that input is sorted and unique
|
||||
trimNames :: [N.NonEmpty T.Text] -> [AcntID]
|
||||
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
|
||||
where
|
||||
trimAll _ [] = []
|
||||
trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
|
||||
(a, [], bs) -> reverse $ trim i a : bs
|
||||
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
|
||||
matchPre i (y, ys, old) new = case (y !? i, new !? i) of
|
||||
(Nothing, Just _) ->
|
||||
case ys of
|
||||
[] -> (new, [], trim i y : old)
|
||||
_ -> err "unsorted input"
|
||||
(Just _, Nothing) -> err "unsorted input"
|
||||
(Nothing, Nothing) -> err "duplicated inputs"
|
||||
(Just a, Just b)
|
||||
| a == b -> (new, y : ys, old)
|
||||
| otherwise ->
|
||||
let next = case ys of
|
||||
[] -> [trim i y]
|
||||
_ -> trimAll (i + 1) (reverse $ y : ys)
|
||||
in (new, [], reverse next ++ old)
|
||||
trim i = N.take (i + 1)
|
||||
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
|
||||
|
||||
(!?) :: N.NonEmpty a -> Int -> Maybe a
|
||||
xs !? n
|
||||
| n < 0 = Nothing
|
||||
-- Definition adapted from GHC.List
|
||||
| otherwise =
|
||||
foldr
|
||||
( \x r k -> case k of
|
||||
0 -> Just x
|
||||
_ -> r (k - 1)
|
||||
)
|
||||
(const Nothing)
|
||||
xs
|
||||
n
|
||||
|
||||
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
||||
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
||||
((IncomeT,) <$> arIncome)
|
||||
++ ((ExpenseT,) <$> arExpenses)
|
||||
++ ((LiabilityT,) <$> arLiabilities)
|
||||
++ ((AssetT,) <$> arAssets)
|
||||
++ ((EquityT,) <$> arEquity)
|
||||
|
||||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
|
||||
indexAcntRoot r =
|
||||
( concat ars
|
||||
, concat aprs
|
||||
, M.fromList $ paths2IDs $ concat ms
|
||||
)
|
||||
where
|
||||
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
|
||||
|
||||
getDBState
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> Config
|
||||
-> m (FilePath -> DBState)
|
||||
getDBState c = do
|
||||
(del, new) <- getConfigHashes c
|
||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
||||
-- in the future so whatever...for now
|
||||
combineError bi si $ \b s f ->
|
||||
-- TODO this can be cleaned up, half of it is meant to be queried when
|
||||
-- determining how to insert budgets/history and the rest is just
|
||||
-- holdover data to delete upon successful insertion
|
||||
DBState
|
||||
{ kmCurrency = currencyMap cs
|
||||
, kmAccount = am
|
||||
, kmBudgetInterval = b
|
||||
, kmStatementInterval = s
|
||||
, kmNewCommits = new
|
||||
, kmOldCommits = del
|
||||
, kmConfigDir = f
|
||||
, kmTag = tagMap ts
|
||||
, kmTagAll = ts
|
||||
, kmAcntPaths = paths
|
||||
, kmAcntsOld = acnts
|
||||
, kmCurrenciesOld = cs
|
||||
}
|
||||
where
|
||||
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
|
||||
si = liftExcept $ resolveBounds $ statementInterval $ global c
|
||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
||||
cs = currency2Record <$> currencies c
|
||||
ts = toRecord <$> tags c
|
||||
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
||||
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||
|
||||
updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateHashes = do
|
||||
old <- askDBState kmOldCommits
|
||||
nukeDBHashes old
|
||||
|
||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateTags = do
|
||||
tags <- askDBState kmTagAll
|
||||
tags' <- selectE $ E.from $ E.table @TagR
|
||||
let (toIns, toDel) = setDiff tags tags'
|
||||
mapM_ deleteTag toDel
|
||||
mapM_ insertFull toIns
|
||||
|
||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateAccounts = do
|
||||
acnts <- askDBState kmAcntsOld
|
||||
paths <- askDBState kmAcntPaths
|
||||
acnts' <- dumpTbl
|
||||
let (toIns, toDel) = setDiff acnts acnts'
|
||||
deleteWhere ([] :: [Filter AccountPathR])
|
||||
mapM_ deleteAccount toDel
|
||||
mapM_ insertFull toIns
|
||||
mapM_ insert paths
|
||||
|
||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateCurrencies = do
|
||||
curs <- askDBState kmCurrenciesOld
|
||||
curs' <- selectE $ E.from $ E.table @CurrencyR
|
||||
let (toIns, toDel) = setDiff curs curs'
|
||||
mapM_ deleteCurrency toDel
|
||||
mapM_ insertFull toIns
|
||||
|
||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateDBState = do
|
||||
updateHashes
|
||||
updateTags
|
||||
updateAccounts
|
||||
updateCurrencies
|
||||
|
||||
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
||||
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
||||
|
||||
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||
|
|
@ -1,567 +0,0 @@
|
|||
module Internal.History
|
||||
( readHistStmt
|
||||
, readHistTransfer
|
||||
, splitHistory
|
||||
, readHistoryCRUD
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Data.Decimal
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import GHC.Real
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
import Text.Regex.TDFA hiding (matchAll)
|
||||
|
||||
readHistoryCRUD
|
||||
:: (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
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Transfers
|
||||
|
||||
readHistTransfer
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> PairedTransfer
|
||||
-> m [Tx CommitR]
|
||||
readHistTransfer ht = do
|
||||
bounds <- asks (unHSpan . tsHistoryScope)
|
||||
expandTransfer c bounds ht
|
||||
where
|
||||
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
readHistStmt
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Either AppException [Tx CommitR])
|
||||
readHistStmt root i = do
|
||||
bounds <- asks (unHSpan . tsHistoryScope)
|
||||
bs <- readImport root i
|
||||
return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
|
||||
where
|
||||
go t@Tx {txMeta = m} =
|
||||
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Either AppException [Tx ()])
|
||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||
runExceptT (matchRecords compiledMatches records)
|
||||
where
|
||||
paths = (root </>) <$> stmtPaths
|
||||
|
||||
readImport_
|
||||
:: MonadUnliftIO m
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
res <- tryIO $ BL.readFile p
|
||||
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ AppException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||
where
|
||||
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
||||
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
||||
|
||||
-- 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
|
||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
||||
parseTxRecord
|
||||
p
|
||||
TxOpts
|
||||
{ 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
|
||||
else -- if we are skipping nothing, proceed to parse the date and amount
|
||||
-- columns
|
||||
do
|
||||
a <- case ax' of
|
||||
Right a -> parseDecimal True af a
|
||||
Left ("", a) -> ((-1) *) <$> parseDecimal False af a
|
||||
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 ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> return ms_
|
||||
(_, us, ns) -> throwError $ AppException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [StatementParserRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [StatementParserRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) ms
|
||||
|
||||
data MatchGroup = MatchGroup
|
||||
{ mgDate :: ![StatementParserRe]
|
||||
, mgNoDate :: ![StatementParserRe]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Zipped a = Zipped ![a] ![a]
|
||||
|
||||
data Unzipped a = Unzipped ![a] ![a] ![a]
|
||||
|
||||
initZipper :: [a] -> Zipped a
|
||||
initZipper = Zipped []
|
||||
|
||||
resetZipper :: Zipped a -> Zipped a
|
||||
resetZipper = initZipper . recoverZipper
|
||||
|
||||
recoverZipper :: Zipped a -> [a]
|
||||
recoverZipper (Zipped as bs) = reverse as ++ bs
|
||||
|
||||
zipperSlice
|
||||
:: (a -> b -> Ordering)
|
||||
-> b
|
||||
-> Zipped a
|
||||
-> Either (Zipped a) (Unzipped a)
|
||||
zipperSlice f x = go
|
||||
where
|
||||
go z@(Zipped _ []) = Left z
|
||||
go z@(Zipped bs (a : as)) =
|
||||
case f a x of
|
||||
GT -> go $ Zipped (a : bs) as
|
||||
EQ -> Right $ goEq (Unzipped bs [a] as)
|
||||
LT -> Left z
|
||||
goEq z@(Unzipped _ _ []) = z
|
||||
goEq z@(Unzipped bs cs (a : as)) =
|
||||
case f a x of
|
||||
GT -> goEq $ Unzipped (a : bs) cs as
|
||||
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||
LT -> z
|
||||
|
||||
zipperMatch
|
||||
:: MonadFinance m
|
||||
=> Unzipped StatementParserRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||
go prev (m : ms) = do
|
||||
res <- matches m x
|
||||
case res of
|
||||
MatchFail -> go (m : prev) ms
|
||||
skipOrPass ->
|
||||
let ps = reverse prev
|
||||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
|
||||
zipperMatch'
|
||||
:: MonadFinance m
|
||||
=> Zipped StatementParserRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
res <- matches a x
|
||||
case res of
|
||||
MatchFail -> go (Zipped (a : bs) as)
|
||||
skipOrPass ->
|
||||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = return (z', MatchFail)
|
||||
|
||||
matchDec :: StatementParserRe -> Maybe StatementParserRe
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll
|
||||
:: MonadFinance m
|
||||
=> [MatchGroup]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
(_, []) -> return (matched, [], unused)
|
||||
([], _) -> return (matched, rs, unused)
|
||||
(g : gs', _) -> do
|
||||
(ts, unmatched, us) <- matchGroup g rs
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
|
||||
matchGroup
|
||||
:: MonadFinance m
|
||||
=> MatchGroup
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(mn, unmatched, un) <- matchNonDates ns rest
|
||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||
|
||||
matchDates
|
||||
:: MonadFinance m
|
||||
=> [StatementParserRe]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) =
|
||||
case zipperSlice findDate r z of
|
||||
Left zipped -> go (matched, r : unmatched, zipped) rs
|
||||
Right unzipped -> do
|
||||
(z', res) <- zipperMatch unzipped r
|
||||
let (m, u) = case res of
|
||||
(MatchPass p) -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
go (m, u, z') rs
|
||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||
|
||||
matchNonDates
|
||||
:: MonadFinance m
|
||||
=> [StatementParserRe]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) = do
|
||||
(z', res) <- zipperMatch' z r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
matches
|
||||
:: MonadFinance m
|
||||
=> StatementParserRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (MatchRes (Tx ()))
|
||||
matches
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
res <- liftInner $
|
||||
combineError3 val other desc $
|
||||
\x y z -> x && y && z && date
|
||||
if res
|
||||
then maybe (return MatchSkip) convert spTx
|
||||
else return MatchFail
|
||||
where
|
||||
val = valMatches spVal $ toRational trAmount
|
||||
date = maybe True (`dateMatches` trDate) spDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
|
||||
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
|
||||
|
||||
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
|
||||
toTx
|
||||
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
|
||||
|
|
@ -0,0 +1,789 @@
|
|||
module Internal.Insert
|
||||
( insertBudget
|
||||
, splitHistory
|
||||
, insertHistTransfer
|
||||
, readHistStmt
|
||||
, insertHistStmt
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Hashable
|
||||
import Database.Persist.Monad
|
||||
import Internal.Statement
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- intervals
|
||||
|
||||
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
|
||||
expandDatePat b (Cron cp) = expandCronPat b cp
|
||||
expandDatePat i (Mod mp) = return $ expandModPat mp i
|
||||
|
||||
expandModPat :: ModPat -> Bounds -> [Day]
|
||||
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
||||
takeWhile (<= upper) $
|
||||
(`addFun` start) . (* b')
|
||||
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||
where
|
||||
(lower, upper) = expandBounds bs
|
||||
start = maybe lower fromGregorian' s
|
||||
b' = fromIntegral b
|
||||
addFun = case u of
|
||||
Day -> addDays
|
||||
Week -> addDays . (* 7)
|
||||
Month -> addGregorianMonthsClip
|
||||
Year -> addGregorianYearsClip
|
||||
|
||||
expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
|
||||
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||
combineError3 yRes mRes dRes $ \ys ms ds ->
|
||||
filter validWeekday $
|
||||
mapMaybe (uncurry3 toDay) $
|
||||
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
|
||||
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||
where
|
||||
yRes = case cpYear of
|
||||
Nothing -> return [yb0 .. yb1]
|
||||
Just pat -> do
|
||||
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||
mRes = expandMD 12 cpMonth
|
||||
dRes = expandMD 31 cpDay
|
||||
(s, e) = expandBounds b
|
||||
(yb0, mb0, db0) = toGregorian s
|
||||
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
||||
expandMD lim =
|
||||
fmap (fromIntegral <$>)
|
||||
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
||||
expandW (OnDay x) = [fromEnum x]
|
||||
expandW (OnDays xs) = fromEnum <$> xs
|
||||
ws = maybe [] expandW cpWeekly
|
||||
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
||||
toDay (y, leap) m d
|
||||
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
||||
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
|
||||
| otherwise = Just $ fromGregorian y m d
|
||||
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
|
||||
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
|
||||
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
||||
expandMDYPat lower upper (After x) = return [max lower x .. upper]
|
||||
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
|
||||
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
|
||||
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
|
||||
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
|
||||
| otherwise = do
|
||||
k <- limit r
|
||||
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
||||
where
|
||||
limit Nothing = return upper
|
||||
limit (Just n)
|
||||
-- this guard not only produces the error for the user but also protects
|
||||
-- from an underflow below it
|
||||
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
|
||||
| otherwise = return $ min (s + b * (n - 1)) upper
|
||||
|
||||
dayToWeekday :: Day -> Int
|
||||
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||
|
||||
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
|
||||
|
||||
foldDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> Day
|
||||
-> (Day -> Day -> m a)
|
||||
-> m [a]
|
||||
foldDates dp start f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- budget
|
||||
|
||||
-- each budget (designated at the top level by a 'name') is processed in the
|
||||
-- following steps
|
||||
-- 1. expand all transactions given the desired date range and date patterns for
|
||||
-- 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 (TODO)
|
||||
-- 5. insert all transactions
|
||||
|
||||
insertBudget
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m ()
|
||||
insertBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
, bgtTransfers
|
||||
, bgtShadowTransfers
|
||||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
} =
|
||||
whenHash CTBudget b () $ \key -> do
|
||||
intAllos <- combineError3 pre_ tax_ post_ (,,)
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
m <- askDBState kmCurrency
|
||||
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
||||
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
||||
where
|
||||
pre_ = sortAllos bgtPretax
|
||||
tax_ = sortAllos bgtTax
|
||||
post_ = sortAllos bgtPosttax
|
||||
sortAllos = liftExcept . combineErrors . fmap sortAllo
|
||||
|
||||
type BoundAllocation = Allocation (Day, Day)
|
||||
|
||||
type IntAllocations =
|
||||
( [BoundAllocation PretaxValue]
|
||||
, [BoundAllocation TaxValue]
|
||||
, [BoundAllocation PosttaxValue]
|
||||
)
|
||||
|
||||
-- TODO this should actually error if there is no ultimate end date?
|
||||
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
bs <- foldBounds [] $ L.sortOn amtWhen as
|
||||
return $ a {alloAmts = reverse bs}
|
||||
where
|
||||
foldBounds acc [] = return acc
|
||||
foldBounds acc (x : xs) = do
|
||||
let start = amtWhen x
|
||||
res <- case xs of
|
||||
[] -> resolveBounds start
|
||||
(y : _) -> resolveBounds_ (intStart $ amtWhen y) start
|
||||
foldBounds (x {amtWhen = expandBounds res} : acc) xs
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
:: CurrencyMap
|
||||
-> [ShadowTransfer]
|
||||
-> [UnbalancedTransfer]
|
||||
-> InsertExcept [UnbalancedTransfer]
|
||||
addShadowTransfers cm ms txs =
|
||||
fmap catMaybes $
|
||||
combineErrors $
|
||||
fmap (uncurry (fromShadow cm)) $
|
||||
[(t, m) | t <- txs, m <- ms]
|
||||
|
||||
fromShadow
|
||||
:: CurrencyMap
|
||||
-> UnbalancedTransfer
|
||||
-> ShadowTransfer
|
||||
-> InsertExcept (Maybe UnbalancedTransfer)
|
||||
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||
res <- shadowMatches (stMatch t) tx
|
||||
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
||||
return $
|
||||
if not res
|
||||
then Nothing
|
||||
else
|
||||
Just $
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
FlatTransfer
|
||||
{ cbtMeta = cbtMeta tx
|
||||
, cbtWhen = cbtWhen tx
|
||||
, cbtCur = stCurrency
|
||||
, cbtFrom = stFrom
|
||||
, cbtTo = stTo
|
||||
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
|
||||
, cbtDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) tmDate
|
||||
&& valRes
|
||||
where
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
|
||||
where
|
||||
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let balTo = M.findWithDefault 0 cbtTo bals
|
||||
x = amtToMove balTo cvType cvValue
|
||||
bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
|
||||
in (bals', f {cbtValue = 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
|
||||
|
||||
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
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !CommitRId
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data FlatTransfer v = FlatTransfer
|
||||
{ cbtFrom :: !TaggedAcnt
|
||||
, cbtTo :: !TaggedAcnt
|
||||
, cbtValue :: !v
|
||||
, cbtWhen :: !Day
|
||||
, cbtDesc :: !T.Text
|
||||
, cbtMeta :: !BudgetMeta
|
||||
, cbtCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data UnbalancedValue = UnbalancedValue
|
||||
{ cvType :: !BudgetTransferType
|
||||
, cvValue :: !Rational
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
||||
|
||||
type BalancedTransfer = FlatTransfer Rational
|
||||
|
||||
insertIncome
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Income
|
||||
-> m [UnbalancedTransfer]
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
, incFrom
|
||||
, incPretax
|
||||
, incPosttax
|
||||
, incTaxes
|
||||
, incToBal
|
||||
, incGross
|
||||
, incPayPeriod
|
||||
} = do
|
||||
-- TODO check that the other accounts are not income somewhere here
|
||||
_ <- checkAcntType IncomeT $ taAcnt incFrom
|
||||
precision <- lookupCurrencyPrec incCurrency
|
||||
let gross = roundPrecision precision incGross
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
res <- foldDates incWhen start (allocate precision gross)
|
||||
return $ concat res
|
||||
where
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
meta = BudgetMeta key name
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
-- TODO ensure these are all the "correct" accounts
|
||||
allocate precision gross prevDay day = do
|
||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||
let (preDeductions, pre) =
|
||||
allocatePre precision gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
tax =
|
||||
allocateTax precision gross preDeductions scaler $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = sumAllos $ tax ++ pre
|
||||
post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = incFrom
|
||||
, cbtCur = NoX incCurrency
|
||||
, cbtTo = incToBal
|
||||
, cbtValue = UnbalancedValue BTFixed balance
|
||||
, cbtDesc = "balance after deductions"
|
||||
}
|
||||
in if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
||||
|
||||
type PeriodScaler = Natural -> Double -> Double
|
||||
|
||||
-- TODO we probably don't need to check for 1/0 each time
|
||||
periodScaler
|
||||
:: PeriodType
|
||||
-> Day
|
||||
-> Day
|
||||
-> InsertExcept PeriodScaler
|
||||
periodScaler pt prev cur = do
|
||||
n <- workingDays wds prev cur
|
||||
return $ scale (fromIntegral n)
|
||||
where
|
||||
wds = case pt of
|
||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||
Daily ds -> ds
|
||||
scale n precision x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* n
|
||||
Daily _ -> x * n / 365.25
|
||||
where
|
||||
rnd = roundPrecision precision
|
||||
|
||||
workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
|
||||
workingDays wds start end
|
||||
| interval > 0 =
|
||||
let (nFull, nPart) = divMod interval 7
|
||||
daysFull = fromIntegral (length wds') * nFull
|
||||
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
|
||||
in return $ fromIntegral $ daysFull + daysTail
|
||||
| otherwise = throwError $ InsertException undefined
|
||||
where
|
||||
interval = diffDays end start
|
||||
startDay = dayOfWeek start
|
||||
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
||||
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
||||
|
||||
allocatePre
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
where
|
||||
go m f@FlatAllocation {faValue} =
|
||||
let c = preCategory faValue
|
||||
p = preValue faValue
|
||||
v =
|
||||
if prePercent faValue
|
||||
then (roundPrecision 3 p / 100) * gross
|
||||
else roundPrecision precision p
|
||||
in (mapAdd_ c v m, f {faValue = v})
|
||||
|
||||
allo2Trans
|
||||
:: BudgetMeta
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> FlatAllocation Rational
|
||||
-> UnbalancedTransfer
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = from
|
||||
, cbtCur = faCur
|
||||
, cbtTo = faTo
|
||||
, cbtValue = UnbalancedValue BTFixed faValue
|
||||
, cbtDesc = faDesc
|
||||
}
|
||||
|
||||
allocateTax
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> M.Map T.Text Rational
|
||||
-> PeriodScaler
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p ->
|
||||
roundPrecision precision $
|
||||
fromRational $
|
||||
roundPrecision 3 p / 100 * agi
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||
|
||||
allocatePost
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocatePost precision aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent} =
|
||||
let v = postValue
|
||||
in if postPercent
|
||||
then aftertax * roundPrecision 3 v / 100
|
||||
else roundPrecision precision v
|
||||
|
||||
-- | Compute effective tax percentage of a bracket
|
||||
-- The algorithm can be thought of in three phases:
|
||||
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
||||
-- than the bracket limit
|
||||
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
|
||||
-- bracket limit and multiplying by the tax percentage.
|
||||
-- 3. Adding all lower brackets, which are just the limit of the bracket less
|
||||
-- the amount of the lower bracket times the percentage.
|
||||
--
|
||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||
-- three steps are implemented from this alone.
|
||||
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
||||
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||
let l = roundPrecision precision $ f precision tbLowerLimit
|
||||
p = roundPrecision 3 tbPercent / 100
|
||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
, faCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
|
||||
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||
go <$> filter ((`inBounds` day) . amtWhen) alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> [BudgetTransfer]
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfers key name ts =
|
||||
fmap (L.sortOn cbtWhen . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer key name) ts
|
||||
|
||||
initialCurrency :: BudgetCurrency -> CurID
|
||||
initialCurrency (NoX c) = c
|
||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
||||
|
||||
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
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ roundPrecision precision v
|
||||
, cbtDesc = desc
|
||||
}
|
||||
|
||||
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
|
||||
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
||||
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ uncurry insertPair
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k split = do
|
||||
sk <- insertSplit k split
|
||||
insert_ $ BudgetLabelR sk $ bmName cbtMeta
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
splitPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> BudgetCurrency
|
||||
-> Rational
|
||||
-> m (SplitPair, Maybe SplitPair)
|
||||
splitPair 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 = split curid from_ (-v)
|
||||
let s2 = split curid to_ v
|
||||
combineError s1 s2 (,)
|
||||
split c TaggedAcnt {taAcnt, taTags} v =
|
||||
resolveSplit $
|
||||
Entry
|
||||
{ eAcnt = taAcnt
|
||||
, eValue = v
|
||||
, eComment = ""
|
||||
, eCurrency = c
|
||||
, eTags = taTags
|
||||
}
|
||||
|
||||
checkAcntType
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> m AcntID
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> m AcntID
|
||||
checkAcntTypes ts i = go =<< lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = return i
|
||||
| otherwise = throwError $ InsertException [AccountError i ts]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- statements
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
-- insertStatement
|
||||
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
|
||||
-- => History
|
||||
-- -> m ()
|
||||
-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
|
||||
-- insertStatement (HistStatement i) = insertImport i
|
||||
|
||||
insertHistTransfer
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
-> m ()
|
||||
insertHistTransfer
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
, transTo = to
|
||||
, transCurrency = u
|
||||
, transAmounts = amts
|
||||
} = do
|
||||
whenHash CTManual m () $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
let precRes = lookupCurrencyPrec u
|
||||
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 :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
|
||||
readHistStmt i = whenHash_ CTImport i $ do
|
||||
bs <- readImport i
|
||||
bounds <- expandBounds <$> askDBState kmStatementInterval
|
||||
liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
|
||||
|
||||
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
|
||||
insertHistStmt c ks = do
|
||||
ck <- insert c
|
||||
mapM_ (insertTx ck) ks
|
||||
|
||||
-- insertImport
|
||||
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
|
||||
-- => Statement
|
||||
-- -> m ()
|
||||
-- insertImport i = whenHash CTImport i () $ \c -> do
|
||||
-- -- TODO this isn't efficient, the whole file will be read and maybe no
|
||||
-- -- transactions will be desired
|
||||
-- bs <- readImport i
|
||||
-- bounds <- expandBounds <$> askDBState kmStatementInterval
|
||||
-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
|
||||
-- mapM_ (insertTx c) keys
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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
|
||||
split a v =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eValue = v
|
||||
, eComment = ""
|
||||
, eCurrency = cur
|
||||
, eTags = []
|
||||
}
|
||||
tx =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
, txDate = day
|
||||
, txSplits = [split from (-val), split to val]
|
||||
}
|
||||
|
||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
||||
resolveTx t@Tx {txSplits = ss} =
|
||||
fmap (\kss -> t {txSplits = kss}) $
|
||||
combineErrors $
|
||||
fmap resolveSplit ss
|
||||
|
||||
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
|
||||
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||
let aRes = lookupAccountKey eAcnt
|
||||
let cRes = lookupCurrencyKey eCurrency
|
||||
let sRes = lookupAccountSign eAcnt
|
||||
let tagRes = combineErrors $ fmap lookupTag eTags
|
||||
-- TODO correct sign here?
|
||||
-- TODO lenses would be nice here
|
||||
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
||||
\(aid, cid, sign) tags ->
|
||||
s
|
||||
{ eAcnt = aid
|
||||
, eCurrency = cid
|
||||
, eValue = eValue * fromIntegral (sign2Int sign)
|
||||
, eTags = tags
|
||||
}
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
||||
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||
k <- insert $ TransactionR c d e
|
||||
mapM_ (insertSplit k) ss
|
||||
|
||||
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
|
||||
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
|
||||
mapM_ (insert_ . TagRelationR k) eTags
|
||||
return k
|
||||
|
||||
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
|
||||
lookupAccount = lookupFinance AcntField kmAccount
|
||||
|
||||
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
|
||||
lookupAccountKey = fmap fstOf3 . lookupAccount
|
||||
|
||||
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
|
||||
lookupAccountSign = fmap sndOf3 . lookupAccount
|
||||
|
||||
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
||||
lookupAccountType = fmap thdOf3 . lookupAccount
|
||||
|
||||
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
|
||||
lookupCurrency = lookupFinance CurField kmCurrency
|
||||
|
||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||
lookupCurrencyKey = fmap fst . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
|
||||
lookupCurrencyPrec = fmap snd . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag = lookupFinance TagField kmTag
|
||||
|
||||
lookupFinance
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> SplitIDType
|
||||
-> (DBState -> M.Map T.Text a)
|
||||
-> T.Text
|
||||
-> m a
|
||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
|
||||
whenHash
|
||||
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> b
|
||||
-> (CommitRId -> m b)
|
||||
-> m b
|
||||
whenHash t o def f = do
|
||||
let h = hash o
|
||||
hs <- askDBState kmNewCommits
|
||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||
|
||||
whenHash_
|
||||
:: (Hashable a, MonadFinance m)
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> m b
|
||||
-> m (Maybe (CommitR, b))
|
||||
whenHash_ t o f = do
|
||||
let h = hash o
|
||||
let c = CommitR h t
|
||||
hs <- askDBState kmNewCommits
|
||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||
|
|
@ -0,0 +1,241 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
|
||||
readImport Statement {..} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
|
||||
m <- askDBState kmCurrency
|
||||
fromEither $
|
||||
flip runReader m $
|
||||
runExceptT $
|
||||
matchRecords compiledMatches records
|
||||
|
||||
readImport_
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- askDBState kmConfigDir
|
||||
res <- tryIO $ BL.readFile $ dir </> p
|
||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||
where
|
||||
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
||||
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
||||
|
||||
-- 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
|
||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
||||
parseTxRecord p TxOpts {..} r = do
|
||||
d <- r .: T.encodeUtf8 toDate
|
||||
if d == ""
|
||||
then return Nothing
|
||||
else do
|
||||
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||
e <- r .: T.encodeUtf8 toDesc
|
||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os p
|
||||
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
-- TODO record number of times each match hits for debugging
|
||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [MatchRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) ms
|
||||
|
||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||
data MatchGroup = MatchGroup
|
||||
{ mgDate :: ![MatchRe]
|
||||
, mgNoDate :: ![MatchRe]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Zipped a = Zipped ![a] ![a]
|
||||
|
||||
data Unzipped a = Unzipped ![a] ![a] ![a]
|
||||
|
||||
initZipper :: [a] -> Zipped a
|
||||
initZipper = Zipped []
|
||||
|
||||
resetZipper :: Zipped a -> Zipped a
|
||||
resetZipper = initZipper . recoverZipper
|
||||
|
||||
recoverZipper :: Zipped a -> [a]
|
||||
recoverZipper (Zipped as bs) = reverse as ++ bs
|
||||
|
||||
zipperSlice
|
||||
:: (a -> b -> Ordering)
|
||||
-> b
|
||||
-> Zipped a
|
||||
-> Either (Zipped a) (Unzipped a)
|
||||
zipperSlice f x = go
|
||||
where
|
||||
go z@(Zipped _ []) = Left z
|
||||
go z@(Zipped bs (a : as)) =
|
||||
case f a x of
|
||||
GT -> go $ Zipped (a : bs) as
|
||||
EQ -> Right $ goEq (Unzipped bs [a] as)
|
||||
LT -> Left z
|
||||
goEq z@(Unzipped _ _ []) = z
|
||||
goEq z@(Unzipped bs cs (a : as)) =
|
||||
case f a x of
|
||||
GT -> goEq $ Unzipped (a : bs) cs as
|
||||
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||
LT -> z
|
||||
|
||||
zipperMatch
|
||||
:: Unzipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||
go prev (m : ms) = do
|
||||
res <- matches m x
|
||||
case res of
|
||||
MatchFail -> go (m : prev) ms
|
||||
skipOrPass ->
|
||||
let ps = reverse prev
|
||||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
|
||||
-- TODO all this unpacking left/error crap is annoying
|
||||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
res <- matches a x
|
||||
case res of
|
||||
MatchFail -> go (Zipped (a : bs) as)
|
||||
skipOrPass ->
|
||||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = return (z', MatchFail)
|
||||
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
(_, []) -> return (matched, [], unused)
|
||||
([], _) -> return (matched, rs, unused)
|
||||
(g : gs', _) -> do
|
||||
(ts, unmatched, us) <- matchGroup g rs
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(mn, unmatched, un) <- matchNonDates ns rest
|
||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) =
|
||||
case zipperSlice findDate r z of
|
||||
Left zipped -> go (matched, r : unmatched, zipped) rs
|
||||
Right unzipped -> do
|
||||
(z', res) <- zipperMatch unzipped r
|
||||
let (m, u) = case res of
|
||||
(MatchPass p) -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
go (m, u, z') rs
|
||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) = do
|
||||
(z', res) <- zipperMatch' z r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTx :: RawTx -> InsertExcept BalTx
|
||||
balanceTx t@Tx {txSplits = ss} = do
|
||||
bs <- balanceSplits ss
|
||||
return $ t {txSplits = bs}
|
||||
|
||||
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
|
||||
balanceSplits ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (eCurrency s, s)) ss
|
||||
where
|
||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
|
||||
| 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]
|
||||
|
||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||
|
|
@ -1,5 +1,4 @@
|
|||
-- | Helper functions so I don't need to write lots of dhall instances
|
||||
module Internal.Types.TH where
|
||||
module Internal.TH where
|
||||
|
||||
import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
|
||||
import RIO
|
||||
|
|
@ -4,24 +4,29 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Types corresponding to the configuration tree (written in Dhall)
|
||||
module Internal.Types.Dhall where
|
||||
module Internal.Types where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Fix (Fix (..), foldFix)
|
||||
import Data.Functor.Foldable (embed)
|
||||
import qualified Data.Functor.Foldable.TH as TH
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Database.Persist.TH
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Dhall.TH
|
||||
import Internal.Types.TH (deriveProduct)
|
||||
import Internal.TH (deriveProduct)
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
|
||||
-------------------------------------------------------------------------------
|
||||
-- DHALL CONFIG
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
|
|
@ -33,14 +38,13 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
|
||||
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
||||
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, 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 "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||
|
|
@ -49,16 +53,12 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
|
||||
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
|
||||
, SingleConstructor
|
||||
"Amount"
|
||||
"Amount"
|
||||
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
|
||||
, SingleConstructor
|
||||
"AcntMatcher_"
|
||||
"AcntMatcher_"
|
||||
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
|
||||
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
|
||||
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
||||
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
||||
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
||||
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
||||
|
|
@ -66,9 +66,14 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
||||
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
||||
, 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 "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
|
||||
|
|
@ -87,13 +92,17 @@ deriveProduct
|
|||
, "CronPat"
|
||||
, "DatePat"
|
||||
, "TaggedAcnt"
|
||||
, "Budget"
|
||||
, "Income"
|
||||
, "ShadowTransfer"
|
||||
, "TransferMatcher"
|
||||
, "AcntSet"
|
||||
, "DateMatcher"
|
||||
, "ValMatcher"
|
||||
, "YMDMatcher"
|
||||
, "BudgetCurrency"
|
||||
, "Exchange"
|
||||
, "EntryNumGetter"
|
||||
, "LinkedNumGetter"
|
||||
, "LinkedEntryNumGetter"
|
||||
, "TemporalScope"
|
||||
, "SqlConfig"
|
||||
, "PretaxValue"
|
||||
|
|
@ -102,8 +111,8 @@ deriveProduct
|
|||
, "TaxProgression"
|
||||
, "TaxMethod"
|
||||
, "PosttaxValue"
|
||||
, "TransferValue"
|
||||
, "TransferType"
|
||||
, "BudgetTransferValue"
|
||||
, "BudgetTransferType"
|
||||
, "Period"
|
||||
, "PeriodType"
|
||||
, "HourlyPeriod"
|
||||
|
|
@ -174,44 +183,23 @@ deriving instance Ord 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
|
||||
|
||||
newtype BudgetName = BudgetName {unBudgetName :: T.Text}
|
||||
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
deriving instance FromDhall BudgetTransfer
|
||||
|
||||
data Budget = Budget
|
||||
{ bgtLabel :: !BudgetName
|
||||
, bgtIncomes :: ![Income]
|
||||
, bgtPretax :: ![MultiAllocation PretaxValue]
|
||||
, bgtTax :: ![MultiAllocation TaxValue]
|
||||
, bgtPosttax :: ![MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: ![PairedTransfer]
|
||||
, bgtShadowTransfers :: ![ShadowTransfer]
|
||||
, 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
|
||||
{ bgtLabel :: Text
|
||||
, bgtIncomes :: [Income]
|
||||
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||
, bgtTax :: [MultiAllocation TaxValue]
|
||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [BudgetTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
|
@ -226,28 +214,17 @@ deriving instance Hashable TaxValue
|
|||
|
||||
deriving instance Hashable PosttaxValue
|
||||
|
||||
deriving instance Hashable TransferValue
|
||||
deriving instance Hashable Budget
|
||||
|
||||
deriving instance Hashable TransferType
|
||||
deriving instance Hashable BudgetTransferValue
|
||||
|
||||
deriving instance Read TransferType
|
||||
|
||||
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 BudgetTransferType
|
||||
|
||||
deriving instance Hashable TaggedAcnt
|
||||
|
||||
deriving instance Ord TaggedAcnt
|
||||
|
||||
newtype CurID = CurID {unCurID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
type CurID = T.Text
|
||||
|
||||
data Income = Income
|
||||
{ incGross :: Double
|
||||
|
|
@ -259,7 +236,6 @@ data Income = Income
|
|||
, incFrom :: TaggedAcnt
|
||||
, incToBal :: TaggedAcnt
|
||||
, incPayPeriod :: !Period
|
||||
, incPriority :: !Int
|
||||
}
|
||||
|
||||
deriving instance Hashable HourlyPeriod
|
||||
|
|
@ -278,13 +254,20 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (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 (Eq w, Eq v) => Eq (Amount w v)
|
||||
|
||||
deriving instance Hashable Exchange
|
||||
|
||||
deriving instance Hashable BudgetCurrency
|
||||
|
||||
data Allocation w v = Allocation
|
||||
{ alloTo :: TaggedAcnt
|
||||
, alloAmts :: [Amount w v]
|
||||
, alloCur :: CurID
|
||||
}
|
||||
deriving (Eq, Show, Generic, Hashable)
|
||||
|
||||
|
|
@ -325,17 +308,11 @@ data Transfer a c w v = Transfer
|
|||
}
|
||||
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 Generic (AcntMatcher_ Text)
|
||||
|
||||
deriving instance Hashable (AcntMatcher_ Text)
|
||||
|
||||
deriving instance FromDhall (AcntMatcher_ Text)
|
||||
deriving instance Hashable TransferMatcher
|
||||
|
||||
deriving instance Hashable ValMatcher
|
||||
|
||||
|
|
@ -367,10 +344,6 @@ instance Ord DateMatcher where
|
|||
|
||||
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
|
||||
-- account tree type
|
||||
|
|
@ -393,7 +366,7 @@ data AccountRoot_ a = AccountRoot_
|
|||
, arIncome :: ![a]
|
||||
, arLiabilities :: ![a]
|
||||
}
|
||||
deriving (Generic, Hashable)
|
||||
deriving (Generic)
|
||||
|
||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||
|
||||
|
|
@ -402,8 +375,10 @@ deriving instance FromDhall AccountRootF
|
|||
type AccountRoot = AccountRoot_ AccountTree
|
||||
|
||||
data Config_ a = Config_
|
||||
{ scope :: !TemporalScope
|
||||
{ global :: !TemporalScope
|
||||
, budget :: ![Budget]
|
||||
, currencies :: ![Currency]
|
||||
, statements :: ![History]
|
||||
, accounts :: !a
|
||||
, tags :: ![Tag]
|
||||
, sqlConfig :: !SqlConfig
|
||||
|
|
@ -433,76 +408,55 @@ instance FromDhall a => FromDhall (Config_ a)
|
|||
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||
|
||||
-- TODO newtypes for these?
|
||||
newtype AcntID = AcntID {unAcntID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
type AcntID = T.Text
|
||||
|
||||
newtype TagID = TagID {unTagID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
type TagID = T.Text
|
||||
|
||||
type HistTransfer = Transfer AcntID CurID DatePat Double
|
||||
|
||||
deriving instance Generic HistTransfer
|
||||
|
||||
deriving instance Hashable HistTransfer
|
||||
|
||||
deriving instance FromDhall HistTransfer
|
||||
|
||||
data History
|
||||
= HistTransfer !PairedTransfer
|
||||
= HistTransfer !HistTransfer
|
||||
| HistStatement !Statement
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
type EntryGetter n = Entry EntryAcnt n TagID
|
||||
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur 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
|
||||
, txSplits :: ![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)
|
||||
|
||||
deriving instance Generic (TxOpts a)
|
||||
|
||||
deriving instance Hashable (TxOpts T.Text)
|
||||
|
||||
deriving instance FromDhall (TxOpts T.Text)
|
||||
|
||||
deriving instance Show a => Show (TxOpts a)
|
||||
|
||||
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 TxOpts re = TxOpts
|
||||
{ toDate :: !T.Text
|
||||
, toAmount :: !T.Text
|
||||
, toDesc :: !T.Text
|
||||
, toOther :: ![T.Text]
|
||||
, toDateFmt :: !T.Text
|
||||
, toAmountFmt :: !re
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Statement = Statement
|
||||
{ stmtPaths :: ![FilePath]
|
||||
|
|
@ -511,32 +465,9 @@ data Statement = Statement
|
|||
, stmtTxOpts :: !(TxOpts T.Text)
|
||||
, 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 split (text version)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
data EntryTextGetter t
|
||||
|
|
@ -544,11 +475,11 @@ data EntryTextGetter t
|
|||
| LookupT !T.Text
|
||||
| MapT !(FieldMap 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 SplitCur = EntryTextGetter CurID
|
||||
|
||||
type EntryAcnt = EntryTextGetter AcntID
|
||||
type SplitAcnt = EntryTextGetter AcntID
|
||||
|
||||
deriving instance (Show k, Show v) => Show (Field k v)
|
||||
|
||||
|
|
@ -576,32 +507,10 @@ data FieldMatcher re
|
|||
|
||||
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
|
||||
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
|
||||
, tgTo :: !(TxHalfGetter ToEntryGetter)
|
||||
, tgCurrency :: !EntryCur
|
||||
, tgOtherEntries :: ![TxSubGetter]
|
||||
, tgScale :: !Double
|
||||
{ tgCurrency :: !SplitCur
|
||||
, tgAcnt :: !SplitAcnt
|
||||
, tgEntries :: ![EntryGetter]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
|
|
@ -618,5 +527,270 @@ data StatementParser re = StatementParser
|
|||
|
||||
deriving instance Show (StatementParser T.Text)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DATABASE MODEL
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
deriving Show Eq
|
||||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
TagR sql=tags
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
deriving Show Eq
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath T.Text
|
||||
desc T.Text
|
||||
deriving Show Eq
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId OnDeleteCascade
|
||||
child AccountRId OnDeleteCascade
|
||||
depth Int
|
||||
deriving Show Eq
|
||||
TransactionR sql=transactions
|
||||
commit CommitRId OnDeleteCascade
|
||||
date Day
|
||||
description T.Text
|
||||
deriving Show Eq
|
||||
SplitR sql=splits
|
||||
transaction TransactionRId OnDeleteCascade
|
||||
currency CurrencyRId OnDeleteCascade
|
||||
account AccountRId OnDeleteCascade
|
||||
memo T.Text
|
||||
value Rational
|
||||
deriving Show Eq
|
||||
TagRelationR sql=tag_relations
|
||||
split SplitRId OnDeleteCascade
|
||||
tag TagRId OnDeleteCascade
|
||||
BudgetLabelR sql=budget_labels
|
||||
split SplitRId OnDeleteCascade
|
||||
budgetName T.Text
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
data ConfigHashes = ConfigHashes
|
||||
{ chIncome :: ![Int]
|
||||
, chExpense :: ![Int]
|
||||
, chManual :: ![Int]
|
||||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
||||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
||||
|
||||
type TagMap = M.Map TagID TagRId
|
||||
|
||||
data DBState = DBState
|
||||
{ kmCurrency :: !CurrencyMap
|
||||
, kmAccount :: !AccountMap
|
||||
, kmTag :: !TagMap
|
||||
, kmBudgetInterval :: !Bounds
|
||||
, kmStatementInterval :: !Bounds
|
||||
, kmNewCommits :: ![Int]
|
||||
, kmOldCommits :: ![Int]
|
||||
, kmConfigDir :: !FilePath
|
||||
, kmTagAll :: ![Entity TagR]
|
||||
, kmAcntPaths :: ![AccountPathR]
|
||||
, kmAcntsOld :: ![Entity AccountR]
|
||||
, kmCurrenciesOld :: ![Entity CurrencyR]
|
||||
}
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
||||
type KeyTx = Tx KeySplit
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type Balances = M.Map AccountRId Rational
|
||||
|
||||
type BalanceM = ReaderT (MVar Balances)
|
||||
|
||||
type MonadFinance = MonadReader DBState
|
||||
|
||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||
askDBState = asks
|
||||
|
||||
class MonadUnliftIO m => MonadBalance m where
|
||||
askBalances :: m (MVar Balances)
|
||||
|
||||
withBalances :: (Balances -> m a) -> m a
|
||||
withBalances f = do
|
||||
bs <- askBalances
|
||||
withMVar bs f
|
||||
|
||||
modifyBalances :: (Balances -> m (Balances, a)) -> m a
|
||||
modifyBalances f = do
|
||||
bs <- askBalances
|
||||
modifyMVar bs f
|
||||
|
||||
lookupBalance :: AccountRId -> m Rational
|
||||
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
|
||||
|
||||
addBalance :: AccountRId -> Rational -> m ()
|
||||
addBalance i v =
|
||||
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: !(M.Map T.Text T.Text)
|
||||
, trFile :: !FilePath
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type Bounds = (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 AcntSign = Credit | Debit
|
||||
deriving (Show)
|
||||
|
||||
sign2Int :: AcntSign -> Int
|
||||
sign2Int Debit = 1
|
||||
sign2Int Credit = 1
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
accountSign AssetT = Debit
|
||||
accountSign ExpenseT = Debit
|
||||
accountSign IncomeT = Credit
|
||||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
|
||||
|
||||
type BalSplit = Entry AcntID Rational CurID TagID
|
||||
|
||||
type RawTx = Tx RawSplit
|
||||
|
||||
type BalTx = Tx BalSplit
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- exception types
|
||||
|
||||
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
||||
|
||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||
|
||||
data SplitIDType = AcntField | CurField | TagField deriving (Show)
|
||||
|
||||
data LookupSuberr
|
||||
= SplitIDField !SplitIDType
|
||||
| SplitValField
|
||||
| MatchField !MatchType
|
||||
| DBKey !SplitIDType
|
||||
deriving (Show)
|
||||
|
||||
data AllocationSuberr
|
||||
= NoAllocations
|
||||
| ExceededTotal
|
||||
| MissingBlank
|
||||
| TooManyBlanks
|
||||
deriving (Show)
|
||||
|
||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||
|
||||
data InsertError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
||||
| InsertIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![RawSplit]
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| BoundsError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
| PeriodError !Day !Day
|
||||
deriving (Show)
|
||||
|
||||
newtype InsertException = InsertException [InsertError]
|
||||
deriving (Show, Semigroup) via [InsertError]
|
||||
|
||||
instance Exception InsertException
|
||||
|
||||
type MonadInsertError = MonadError InsertException
|
||||
|
||||
type InsertExceptT = ExceptT InsertException
|
||||
|
||||
type InsertExcept = InsertExceptT Identity
|
||||
|
||||
data XGregorian = XGregorian
|
||||
{ xgYear :: !Int
|
||||
, xgMonth :: !Int
|
||||
, xgDay :: !Int
|
||||
, xgDayOfWeek :: !Int
|
||||
}
|
||||
|
||||
type MatchRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||
|
||||
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
||||
|
||||
instance Show (StatementParser (T.Text, Regex)) where
|
||||
show = show . fmap fst
|
||||
|
|
@ -1,187 +0,0 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Types corresponding to the database model
|
||||
module Internal.Types.Database where
|
||||
|
||||
import Data.Csv (FromField)
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Database.Persist.TH
|
||||
import Internal.Types.Dhall
|
||||
import RIO
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash CommitHash
|
||||
type ConfigType
|
||||
UniqueCommitHash hash
|
||||
deriving Show Eq Ord
|
||||
|
||||
ConfigStateR sql=config_state
|
||||
historySpan HistorySpan
|
||||
budgetSpan BudgetSpan
|
||||
deriving Show
|
||||
|
||||
CurrencyR sql=currencies
|
||||
symbol CurID
|
||||
fullname T.Text
|
||||
precision Precision
|
||||
UniqueCurrencySymbol symbol
|
||||
UniqueCurrencyFullname fullname
|
||||
deriving Show Eq Ord
|
||||
|
||||
TagR sql=tags
|
||||
symbol TagID
|
||||
fullname T.Text
|
||||
UniqueTagSymbol symbol
|
||||
UniqueTagFullname fullname
|
||||
deriving Show Eq Ord
|
||||
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath AcntPath
|
||||
desc T.Text
|
||||
sign AcntSign
|
||||
leaf Bool
|
||||
UniqueAccountFullpath fullpath
|
||||
deriving Show Eq Ord
|
||||
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId
|
||||
child AccountRId
|
||||
depth Int
|
||||
deriving Show Eq Ord
|
||||
|
||||
TransactionR sql=transactions
|
||||
commit CommitRId
|
||||
date Day
|
||||
budgetName BudgetName
|
||||
description TxDesc
|
||||
priority Int
|
||||
deriving Show Eq
|
||||
|
||||
EntrySetR sql=entry_sets
|
||||
transaction TransactionRId
|
||||
currency CurrencyRId
|
||||
index EntrySetIndex
|
||||
rebalance Bool
|
||||
deriving Show Eq
|
||||
|
||||
EntryR sql=entries
|
||||
entryset EntrySetRId
|
||||
account AccountRId
|
||||
memo T.Text
|
||||
value Rational
|
||||
index EntryIndex
|
||||
cachedValue (Maybe Rational)
|
||||
cachedType (Maybe TransferType)
|
||||
cachedLink (Maybe EntryIndex)
|
||||
deriving Show Eq
|
||||
|
||||
TagRelationR sql=tag_relations
|
||||
entry EntryRId
|
||||
tag TagRId
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
newtype TxIndex = TxIndex {unTxIndex :: Int}
|
||||
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
|
||||
|
||||
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
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "not a string"
|
||||
|
||||
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"
|
||||
|
|
@ -1,332 +0,0 @@
|
|||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Other types used throughout the program; kept in its own module to prevent
|
||||
-- circular imports
|
||||
module Internal.Types.Main
|
||||
( module Internal.Types.Main
|
||||
, module Internal.Types.Dhall
|
||||
, module Internal.Types.Database
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Decimal
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Internal.Types.Database
|
||||
import Internal.Types.Dhall
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
type MonadFinance = MonadReader TxState
|
||||
|
||||
data DeleteTxs = DeleteTxs
|
||||
{ dtCommits :: ![CommitRId]
|
||||
, dtTxs :: ![TransactionRId]
|
||||
, 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 PreBudgetCRUD = BudgetCRUDOps Budget
|
||||
|
||||
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
|
||||
|
||||
data CRUDOps c r u d = CRUDOps
|
||||
{ coCreate :: !c
|
||||
, coRead :: !r
|
||||
, coUpdate :: !u
|
||||
, coDelete :: !d
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data CachedEntry
|
||||
= CachedLink EntryIndex LinkScale
|
||||
| CachedBalance Decimal
|
||||
| CachedPercent Double
|
||||
|
||||
data TxSortKey = TxSortKey
|
||||
{ tskDate :: !Day
|
||||
, tskPriority :: !Int
|
||||
, tskDesc :: !TxDesc
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- TODO this should actually be a ReadTx since it will be compared with other
|
||||
-- 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
|
||||
{ ueID :: !i
|
||||
, ueAcnt :: !AccountRId
|
||||
, ueValue :: !v
|
||||
, ueIndex :: !EntryIndex
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
deriving instance Functor (UpdateEntry i)
|
||||
|
||||
newtype LinkScale = LinkScale {unLinkScale :: Double}
|
||||
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
|
||||
|
||||
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
||||
deriving newtype (Num, Show)
|
||||
|
||||
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
|
||||
|
||||
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
|
||||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Decimal
|
||||
, trDesc :: !TxDesc
|
||||
, trOther :: !(M.Map T.Text T.Text)
|
||||
, trFile :: !FilePath
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
accountSign AssetT = Debit
|
||||
accountSign ExpenseT = Debit
|
||||
accountSign IncomeT = Credit
|
||||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
data HalfEntrySet v0 vN = HalfEntrySet
|
||||
{ hesPrimary :: !(Entry AcntID v0 TagID)
|
||||
, hesOther :: ![Entry AcntID vN TagID]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data EntrySet v0 vp0 vpN vtN = EntrySet
|
||||
{ esTotalValue :: !v0
|
||||
, esCurrency :: !CurrencyRId
|
||||
, esFrom :: !(HalfEntrySet vp0 vpN)
|
||||
, esTo :: !(HalfEntrySet () vtN)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
|
||||
|
||||
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
|
||||
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- exception types
|
||||
|
||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||
|
||||
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||
|
||||
data LookupSuberr
|
||||
= EntryIDField !EntryIDType
|
||||
| EntryValField
|
||||
| MatchField !MatchType
|
||||
| DBKey !EntryIDType
|
||||
deriving (Show)
|
||||
|
||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||
|
||||
data DBLinkSubError
|
||||
= DBLinkNoScale
|
||||
| DBLinkNoValue
|
||||
| DBLinkInvalidValue !Rational !Bool
|
||||
| DBLinkInvalidBalance
|
||||
| DBLinkInvalidPercent
|
||||
deriving (Show)
|
||||
|
||||
data DBSubError
|
||||
= DBShouldBeEmpty
|
||||
| DBMultiScope
|
||||
| DBUpdateUnbalanced
|
||||
| DBLinkError !EntryRId !DBLinkSubError
|
||||
deriving (Show)
|
||||
|
||||
data AppError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
|
||||
| StatementIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text !Bool
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![StatementParserRe]
|
||||
| PeriodError !Day !Day
|
||||
| LinkError !EntryIndex !EntryIndex
|
||||
| DBError !DBSubError
|
||||
deriving (Show)
|
||||
|
||||
newtype AppException = AppException [AppError]
|
||||
deriving (Show, Semigroup) via [AppError]
|
||||
|
||||
instance Exception AppException
|
||||
|
||||
type MonadAppError = MonadError AppException
|
||||
|
||||
type AppExceptT = ExceptT AppException
|
||||
|
||||
type AppExcept = AppExceptT Identity
|
||||
|
||||
type StatementParserRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TransferMatcherRe = TransferMatcher_ Regex
|
||||
|
||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||
|
||||
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -87,7 +87,6 @@ dependencies:
|
|||
- filepath
|
||||
- mtl
|
||||
- persistent-mtl >= 0.3.0.0
|
||||
- Decimal >= 0.5.2
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
|
|
|
|||
Loading…
Reference in New Issue