ENH use sane types to simplify tx balancing

This commit is contained in:
Nathan Dwarshuis 2023-06-16 22:05:28 -04:00
parent 6926003c46
commit ad0975aba7
6 changed files with 411 additions and 264 deletions

View File

@ -396,31 +396,21 @@ let FieldMatcher_ =
let FieldMatcher = FieldMatcher_ Text
let FromEntryNumGetter =
let EntryNumGetter =
{-
Means to get a numeric value from a statement row.
FLookupN: lookup the value from a field
FConstN: a constant value
FAmountN: the value of the 'Amount' column
FBalanceN: the amount required to make the target account reach a balance
LookupN: lookup the value from a field
ConstN: a constant value
AmountN: the value of the 'Amount' column
BalanceN: the amount required to make the target account reach a balance
-}
< FLookupN : Text
| FConstN : Double
| FAmountN : Double
| FBalanceN : Double
< LookupN : Text
| ConstN : Double
| AmountN : Double
| BalanceN : Double
>
let ToEntryNumGetter =
{-
Means to get a numeric value from a statement row.
TLookupN: lookup the value from a field
TConstN: a constant value
TAmountN: the value of the 'Amount' column
-}
< TLookupN : Text | TConstN : Double | TAmountN : Double >
let EntryTextGetter =
{-
Means to get a textual value from a statement row.
@ -458,7 +448,6 @@ let Entry =
-}
\(a : Type) ->
\(v : Type) ->
\(c : Type) ->
\(t : Type) ->
{ eAcnt :
{-
@ -470,11 +459,6 @@ 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)
@ -487,31 +471,65 @@ let Entry =
List t
}
let FromEntryGetter =
let EntryGetter =
{-
Means for getting an entry from a given row in a statement to apply to the
credit side of the transaction.
Means for getting an entry from a given row in a statement
-}
{ Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
, default = { eValue = None FromEntryNumGetter, eComment = "" }
{ Type = Entry EntryAcntGetter EntryNumGetter TagID
, default = { eValue = None EntryNumGetter, eComment = "" }
}
let ToEntryGetter =
let TxSubGetter =
{-
Means for getting an entry from a given row in a statement to apply to the
debit side of the transaction.
A means for transforming one row in a statement to a transaction
-}
{ Type =
Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
, default = { eValue = None ToEntryNumGetter, eComment = "" }
{ tsgFromAcnt :
{-
-}
EntryAcntGetter
, tsgToAcnt :
{-
-}
EntryAcntGetter
, tsgValue :
{-
-}
EntryNumGetter
, tsgCurrency :
{-
-}
EntryCurGetter
, tsgFromEntries :
{-
-}
List EntryGetter.Type
, tsgToEntries :
{-
A means of getting entries for this transaction (minimum 1)
-}
List EntryGetter.Type
}
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.
At least two entries must be made for any given transaction. Below these
correspond to the 'from' and 'to' accounts, which will share a single value
(whose positive is added to 'to' and negative is added to 'from' accounts)
given by the record (ie one row in a statement) denominated in the given
currency.
Optionally, both sides of the from/to flow of value can be split with other
accounts (given by 'tgFromEntries' and 'tgToEntries'). In either case, the
amount actually transferred between the 'from' and 'to' accounts above
will be the difference after considering these additional account entries.
Furthermore, additionally entries denominated in different currencies
may be specified via 'tgOtherEntries'. Each member in this list corresponds
to a different currency (and associated entries) governed by most of the
rules for this type regarding balancing and splitting value.
-}
{ tgFromAcnt :
{-
@ -520,7 +538,14 @@ let TxGetter =
entries are specified (see below).
-}
EntryAcntGetter
, tgFromCurrency :
, tgToAcnt :
{-
Account from which this transaction will be balanced. The value of
the transaction will be assigned to this account unless other from
entries are specified (see below).
-}
EntryAcntGetter
, tgCurrency :
{-
Currency to assign to the account/value denoted by 'tgFromAcnt'
above.
@ -538,12 +563,16 @@ let TxGetter =
This is useful for situations where a particular transaction denotes
values that come from multiple subaccounts.
-}
List FromEntryGetter.Type
List EntryGetter.Type
, tgToEntries :
{-
A means of getting entries for this transaction (minimum 1)
A means of getting entries for this transaction
-}
List ToEntryGetter.Type
List EntryGetter.Type
, tgOtherEntries :
{-
-}
List TxSubGetter
}
let StatementParser_ =
@ -1088,13 +1117,11 @@ in { CurID
, DateMatcher
, FieldMatcher
, FieldMatcher_
, FromEntryNumGetter
, ToEntryNumGetter
, EntryNumGetter
, Field
, FieldMap
, Entry
, FromEntryGetter
, ToEntryGetter
, EntryGetter
, EntryTextGetter
, EntryCurGetter
, EntryAcntGetter

View File

@ -11,7 +11,9 @@ module Internal.Database
, whenHash
, whenHash_
, insertEntry
-- , insertEntrySet
, resolveEntry
-- , resolveEntrySet
)
where
@ -393,15 +395,15 @@ whenHash_ t o f = do
if h `elem` hs then Just . (c,) <$> f else return Nothing
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do
k <- insert $ EntryR t feCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let cRes = lookupCurrencyKey feCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
@ -409,8 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = fromIntegral (sign2Int sign) * eValue
, eTags = tags
{ feCurrency = cid
, feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
}

View File

@ -8,7 +8,8 @@ where
import Control.Monad.Except
import Data.Csv
import Database.Persist.Monad
import Data.Foldable
import Database.Persist.Monad hiding (get)
import Internal.Database
import Internal.Types.Main
import Internal.Utils
@ -18,6 +19,7 @@ import RIO.FilePath
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
@ -26,7 +28,7 @@ import qualified RIO.Vector as V
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
-- => FilePath
-- -> [History]
-- -> m [(CommitR, [RawTx])]
-- -> m [(CommitR, [DeferredTx])]
-- readHistory root hs = do
-- let (ts, ss) = splitHistory hs
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
@ -36,7 +38,7 @@ import qualified RIO.Vector as V
readHistTransfer
:: (MonadInsertError m, MonadFinance m)
=> HistTransfer
-> m (Maybe (CommitR, [RawTx]))
-> m (Maybe (CommitR, [DeferredTx]))
readHistTransfer
m@Transfer
{ transFrom = from
@ -63,11 +65,11 @@ readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Maybe (CommitR, [RawTx]))
-> m (Maybe (CommitR, [DeferredTx]))
readHistStmt root i = whenHash_ CTImport i $ do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) bs
return $ filter (inDaySpan bounds . dtxDate) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
@ -77,7 +79,7 @@ splitHistory = partitionEithers . fmap go
insertHistory
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [(CommitR, [RawTx])]
=> [(CommitR, [DeferredTx])]
-> m ()
insertHistory hs = do
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
@ -96,30 +98,37 @@ txPair
-> CurID
-> Rational
-> T.Text
-> RawTx
txPair day from to cur val desc = tx
-> DeferredTx
txPair day from to cur val desc =
Tx
{ dtxDescr = desc
, dtxDate = day
, dtxEntries =
[ EntrySet
{ desTotalValue = val
, desCurrency = cur
, desFromEntry0 = entry from
, desToEntryBal = entry to
, desFromEntries = []
, desToEntries = []
}
]
}
where
split a v =
entry a =
Entry
{ eAcnt = a
, eValue = ConstD v
, eValue = ()
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txEntries = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txEntries = ss} =
fmap (\kss -> t {txEntries = kss}) $ combineErrors $ fmap resolveEntry ss
resolveTx t@Tx {dtxEntries = ss} =
(\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
@ -127,7 +136,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
-- Statements
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
@ -175,7 +184,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
-- TODO need to somehow balance temporally here (like I do in the budget for
-- directives that "pay off" a balance)
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
@ -236,7 +245,7 @@ zipperSlice f x = go
zipperMatch
:: Unzipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -252,7 +261,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
zipperMatch'
:: Zipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
@ -269,7 +278,7 @@ matchDec m = case spTimes m of
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
@ -279,13 +288,13 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [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 :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -306,7 +315,7 @@ matchDates ms = go ([], [], initZipper ms)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -323,63 +332,74 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
-- TDOO should use a better type here to squish down all the entry sets
-- which at this point in the chain should not be necessary
balanceTxs
:: (MonadInsertError m, MonadFinance m)
=> [(CommitR, RawTx)]
=> [(CommitR, DeferredTx)]
-> m [(CommitR, KeyTx)]
balanceTxs ts = do
bs <- mapErrors balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
return $ zip cs bs
keyts <- mapErrors resolveTx balTs
return $ zip cs keyts
where
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
(cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
go bals t@Tx {dtxEntries} =
second (\es -> t {dtxEntries = concat es}) $
L.mapAccumL balanceEntrySet bals dtxEntries
balTs = snd $ L.mapAccumL go M.empty ts'
balanceTxTargets
:: (Ord a, Ord c)
=> M.Map (a, c) Rational
-> Tx (Entry a (Deferred Rational) c t)
-> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
where
(bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
type EntryBals = M.Map (AcntID, CurID) Rational
balanceEntryTargets
:: (Ord a, Ord c)
=> M.Map (a, c) Rational
-> Entry a (Deferred Rational) c t
-> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
-- TODO might be faster to also do all the key stuff here since currency
-- will be looked up for every entry rather then the entire entry set
balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
balanceEntrySet
bals
EntrySet
{ desFromEntry0
, desFromEntries
, desToEntryBal
, desToEntries
, desCurrency
, desTotalValue
} = flipTup $ runState doBalAll bals
where
key = (eAcnt, eCurrency)
flipTup (a, b) = (b, a)
doEntries es tot e0 = do
es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
let val0 = tot - entrySum es'
modify $ mapAdd_ (eAcnt e0, desCurrency) val0
return $ e0 {eValue = val0} : es'
doBalAll = do
fes <- doEntries desFromEntries desTotalValue desFromEntry0
tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
return $ toFull <$> fes ++ tes
toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
entrySum :: Num v => [Entry a v t] -> v
entrySum = sum . fmap eValue
balanceEntry
:: CurID
-> EntryBals
-> Entry AcntID (Deferred Rational) TagID
-> (EntryBals, Entry AcntID Rational TagID)
balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt}
| toBal = (bals, e {eValue = v})
| otherwise = (bals', e {eValue = newVal})
where
key = (eAcnt, curID)
curBal = M.findWithDefault 0 key bals
v = case eValue of
ConstD x -> Just x
Target x -> Just $ x - curBal
Derive -> Nothing
bals' = maybe bals (\y -> mapAdd_ key y bals) v
newVal = v - curBal
bals' = mapAdd_ key newVal bals
balanceTx
:: (MonadInsertError m, MonadFinance m)
=> Tx (Entry AcntID (Maybe Rational) CurID TagID)
-> m KeyTx
balanceTx t@Tx {txEntries = ss} = do
bs <- liftExcept $ balanceEntries ss
resolveTx $ t {txEntries = bs}
balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
balanceEntries 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 TooFewEntries 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 (: []))
-- -- reimplementation from future version :/
-- mapAccumM
-- :: Monad m
-- => (s -> a -> m (s, b))
-- -> s
-- -> [a]
-- -> m (s, [b])
-- mapAccumM f s xs = foldrM go (s, []) xs
-- where
-- go x (s', acc) = second (: acc) <$> f s' x

View File

@ -19,7 +19,7 @@ import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
-- import RIO.Time
import Text.Regex.TDFA
makeHaskellTypesWith
@ -32,8 +32,7 @@ makeHaskellTypesWith
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
, MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
@ -98,8 +97,7 @@ deriveProduct
, "YMDMatcher"
, "BudgetCurrency"
, "Exchange"
, "FromEntryNumGetter"
, "ToEntryNumGetter"
, "EntryNumGetter"
, "TemporalScope"
, "SqlConfig"
, "PretaxValue"
@ -340,9 +338,7 @@ instance Ord DateMatcher where
compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT
deriving instance Hashable FromEntryNumGetter
deriving instance Hashable ToEntryNumGetter
deriving instance Hashable EntryNumGetter
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
@ -425,28 +421,17 @@ data History
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
instance FromDhall EntryGetter
instance FromDhall ToEntryGetter
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
instance FromDhall FromEntryGetter
deriving instance Generic (Entry a v t)
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
deriving instance Generic (Entry a v c t)
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txEntries :: ![s]
}
deriving (Generic)
deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
data TxOpts re = TxOpts
{ toDate :: !T.Text
@ -507,11 +492,23 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text)
data TxSubGetter = TxSubGetter
{ tsgFromAcnt :: !EntryAcnt
, tsgToAcnt :: !EntryAcnt
, tsgValue :: !EntryNumGetter
, tsgCurrency :: !EntryCur
, tsgFromEntries :: ![EntryGetter]
, tsgToEntries :: ![EntryGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data TxGetter = TxGetter
{ tgFromAcnt :: !EntryAcnt
, tgFromCurrency :: !EntryCur
, tgFromEntries :: ![FromEntryGetter]
, tgToEntries :: ![ToEntryGetter]
, tgToAcnt :: !EntryAcnt
, tgCurrency :: !EntryCur
, tgFromEntries :: ![EntryGetter]
, tgToEntries :: ![EntryGetter]
, tgOtherEntries :: ![TxSubGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)

View File

@ -59,13 +59,20 @@ data DBUpdates = DBUpdates
type CurrencyM = Reader CurrencyMap
type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
data FullEntry a c t = FullEntry
{ feCurrency :: !c
, feEntry :: !(Entry a Rational t)
}
type DeferredKeyTx = Tx DeferredKeyEntry
type KeyEntry = FullEntry AccountRId CurrencyRId TagRId
type KeyTx = Tx KeyEntry
type BalEntry = FullEntry AcntID CurID TagID
-- type DeferredKeyTx = Tx DeferredKeyEntry
-- type KeyTx = Tx KeyEntry
type TreeR = Tree ([T.Text], AccountRId)
@ -131,18 +138,46 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
data Deferred a = ConstD a | Target a | Derive
data EntrySet a c t v = EntrySet
{ desTotalValue :: !Rational
, desCurrency :: !c
, desFromEntry0 :: !(Entry a () t)
, desFromEntries :: ![Entry a v t]
, desToEntries :: ![Entry a v t]
, desToEntryBal :: !(Entry a () t)
}
data Tx e = Tx
{ dtxDescr :: !T.Text
, dtxDate :: !Day
, dtxEntries :: !e
}
deriving (Generic)
type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
type BalEntrySet = EntrySet AcntID CurID TagID Rational
type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
type DeferredTx = Tx [DeferredEntrySet]
type BalTx = Tx [BalEntry]
type KeyTx = Tx [KeyEntry]
data Deferred a = Deferred Bool a
deriving (Show, Functor, Foldable, Traversable)
type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
type BalEntry = Entry AcntID Rational CurID TagID
-- type BalEntry = Entry AcntID Rational CurID TagID
type RawTx = Tx RawEntry
-- type RawTx = Tx RawEntry
type BalTx = Tx BalEntry
-- type BalTx = Tx BalEntry
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
@ -179,8 +214,8 @@ data InsertError
| ParseError !T.Text
| ConversionError !T.Text
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
| IncomeError !Day !T.Text !Rational
| -- | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]

View File

@ -290,7 +290,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
--------------------------------------------------------------------------------
-- matching
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx)
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@ -305,39 +305,108 @@ matches
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert TxGetter {tgFromAcnt, tgFromCurrency, tgFromEntries, tgToEntries} =
MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r
convert tg = MatchPass <$> toTx tg r
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
toTx
:: EntryCur
-> EntryAcnt
-> [FromEntryGetter]
-> [ToEntryGetter]
-> TxRecord
-> InsertExceptT CurrencyM RawTx
toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
combineError
(combineError acntRes curRes (,))
(combineError fromRes toRes (,))
$ \(a, c) (fs, ts) ->
TxGetter {tgFromAcnt, tgToAcnt, tgCurrency, tgFromEntries, tgToEntries, tgOtherEntries}
r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> do
let fromEntry =
Entry
{ eAcnt = a
, eCurrency = c
, eValue = ConstD trAmount
{ eAcnt = fa
, eValue = ()
, eComment = "" -- TODO actually fill this in
, eTags = [] -- TODO what goes here?
}
toEntry =
Entry
{ eAcnt = ta
, eValue = ()
, eComment = ""
, eTags = []
}
in Tx
{ txDate = trDate
, txDescr = trDesc
, txEntries = fromEntry : fs ++ ts
{ dtxDate = trDate
, dtxDescr = trDesc
, dtxEntries =
EntrySet
{ desTotalValue = trAmount
, desCurrency = cur
, desFromEntry0 = fromEntry
, desFromEntries = fe
, desToEntries = te
, desToEntryBal = toEntry
}
: ss
}
where
acntRes = liftInner $ resolveAcnt r sa
curRes = liftInner $ resolveCurrency r sc
fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
toRes = combineErrors $ fmap (resolveToEntry r) toEntries
resolveAcnt_ = liftInner . resolveAcnt r
acntRes =
combineError
(resolveAcnt_ tgFromAcnt)
(resolveAcnt_ tgToAcnt)
(,)
curRes = do
cur <- liftInner $ resolveCurrency r tgCurrency
let feRes = mapErrors (resolveEntry cur r) tgFromEntries
let teRes = mapErrors (resolveEntry cur r) tgToEntries
combineError feRes teRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
resolveSubGetter
:: TxRecord
-> TxSubGetter
-> InsertExceptT CurrencyM DeferredEntrySet
resolveSubGetter
r
TxSubGetter
{ tsgFromAcnt
, tsgToAcnt
, tsgValue
, tsgCurrency
, tsgFromEntries
, tsgToEntries
} = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
do
m <- ask
-- TODO laaaaame...
(Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
let fromEntry =
Entry
{ eAcnt = fa
, eValue = ()
, eComment = "" -- TODO actually fill this in
, eTags = [] -- TODO what goes here?
}
let toEntry =
Entry
{ eAcnt = ta
, eValue = ()
, eComment = ""
, eTags = []
}
return
EntrySet
{ desTotalValue = val
, desCurrency = cur
, desFromEntry0 = fromEntry
, desFromEntries = fe
, desToEntries = te
, desToEntryBal = toEntry
}
where
resolveAcnt_ = liftInner . resolveAcnt r
acntRes =
combineError
(resolveAcnt_ tsgFromAcnt)
(resolveAcnt_ tsgToAcnt)
(,)
curRes = do
cur <- liftInner $ resolveCurrency r tsgCurrency
let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
let teRes = mapErrors (resolveEntry cur r) tsgToEntries
combineError feRes teRes (cur,,)
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@ -363,28 +432,34 @@ otherMatches dict m = case m of
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-- TODO this should be more general?
resolveEntry
:: CurID
-> TxRecord
-> EntryGetter
-> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
resolveEntry cur r s@Entry {eAcnt, eValue} = do
m <- ask
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
v' <- mapM (roundPrecisionCur c m) v
return $ s {eAcnt = a, eValue = v', eCurrency = c}
liftInner $ combineErrorM acntRes valRes $ \a v -> do
v' <- mapM (roundPrecisionCur cur m) v
return $ s {eAcnt = a, eValue = v'}
where
acntRes = resolveAcnt r eAcnt
curRes = resolveCurrency r eCurrency
valRes = resolveFromValue r eValue
valRes = resolveValue r eValue
-- TODO wet code (kinda, not sure if it's worth combining with above)
resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
m <- ask
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
v' <- mapM (roundPrecisionCur c m) v
return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
where
acntRes = resolveAcnt r eAcnt
curRes = resolveCurrency r eCurrency
valRes = mapM (resolveToValue r) eValue
-- curRes = resolveCurrency r eCurrency
-- -- TODO wet code (kinda, not sure if it's worth combining with above)
-- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
-- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-- m <- ask
-- liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-- v' <- mapM (roundPrecisionCur c m) v
-- return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
-- where
-- acntRes = resolveAcnt r eAcnt
-- curRes = resolveCurrency r eCurrency
-- valRes = mapM (resolveToValue r) eValue
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity)
@ -428,17 +503,28 @@ combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -
combineErrorM3 a b c f = do
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
combineErrors :: MonadError InsertException m => [m a] -> m [a]
mapErrors
:: (Traversable t, MonadError InsertException m)
=> (a -> m b)
-> t a
-> m (t b)
-- First, record number of each action. Then try each action. On first failure,
-- note it's position in the sequence, skip ahead to the untried actions,
-- collect failures and add to the first failure.
mapErrors f xs = mapM go $ enumTraversable xs
where
go (n, x) = catchError (f x) $ \e -> do
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwError $ foldr (<>) e es
err x = catchError (Nothing <$ x) (pure . Just)
combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a)
combineErrors = mapErrors id
mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
mapErrors f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(e : es, _) -> throwError $ foldr (<>) e es
enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
enumTraversable = snd . L.mapAccumL go 0
where
go x = catchError (Right <$> x) (pure . Left)
go n x = (n + 1, (n, x))
combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
@ -457,31 +543,30 @@ combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d)
combineErrorIOM3 a b c f =
combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
mapErrorsIO f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(es, _) -> throwIO $ InsertException $ concat es
mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
mapErrorsIO f xs = mapM go $ enumTraversable xs
where
go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
go (n, x) = catch (f x) $ \(InsertException e) -> do
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwIO $ InsertException $ foldr (<>) e es
err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id
resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
resolveFromValue TxRecord {trOther, trAmount} s = case s of
(FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
(FConstN c) -> return $ ConstD c
FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
FBalanceN x -> return $ Target x
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
resolveValue TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ Deferred False c
AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
BalanceN x -> return $ Deferred True x
-- TODO not DRY
resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
resolveToValue TxRecord {trOther, trAmount} s = case s of
(TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
(TConstN c) -> return c
TAmountN m -> return $ (* m) $ fromRational trAmount
-- -- TODO not DRY
-- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
-- resolveToValue TxRecord {trOther, trAmount} s = case s of
-- (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
-- (TConstN c) -> return c
-- TAmountN m -> return $ (* m) $ fromRational trAmount
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField
@ -656,20 +741,6 @@ showError other = case other of
, singleQuote $ showT next
]
]
(BalanceError t cur rss) ->
[ T.unwords
[ msg
, "for currency"
, singleQuote cur
, "and for entries"
, entries
]
]
where
msg = case t of
TooFewEntries -> "Need at least two entries to balance"
NotOneBlank -> "Exactly one entries must be blank"
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
@ -757,14 +828,6 @@ showMatchOther (Val (Field f mv)) =
, singleQuote $ fromMaybe "*" $ showValMatcher mv
]
showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
showEntry Entry {eAcnt, eValue, eComment} =
keyVals
[ ("account", eAcnt)
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
, ("comment", doubleQuote eComment)
]
singleQuote :: T.Text -> T.Text
singleQuote t = T.concat ["'", t, "'"]
@ -856,6 +919,11 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
-- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
-- groupKey f = fmap go . NE.groupAllWith (f . fst)
-- where
-- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
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