From 776a10ba118454d2d132b952a046df15835f7f6a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 10 Jun 2023 21:30:30 -0400 Subject: [PATCH] ENH allow multiple entries on credit side of transaction statement getter --- dhall/Types.dhall | 57 ++++++++++++++++++++++++--------- lib/Internal/Types/Dhall.hs | 19 +++++------ lib/Internal/Types/Main.hs | 2 ++ lib/Internal/Utils.hs | 63 ++++++++++++++++++++++++++----------- 4 files changed, 98 insertions(+), 43 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 2e584b2..ff279eb 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -472,9 +472,19 @@ let Entry = List t } -let EntryGetter = +let FromEntryGetter = {- - Means for getting an entry from a given row in a statement + Means for getting an entry from a given row in a statement to apply to the + credit side of the transaction. + -} + { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID + , default = { eValue = None EntryNumGetter, eComment = "" } + } + +let ToEntryGetter = + {- + Means for getting an entry from a given row in a statement to apply to the + debit side of the transaction. -} { Type = Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID @@ -488,21 +498,37 @@ let TxGetter = Note that N-1 entries need to be specified to make a transaction, as the Nth entry will be balanced with the others. -} - { tgEntries : + { tgFromAcnt : + {- + 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 + , tgFromCurrency : + {- + Currency to assign to the account/value denoted by 'tgFromAcnt' + above. + -} + EntryCurGetter + , tgFromEntries : + {- + Means of getting additional entries from which this transaction will + be balanced (minimum 0). If this list is empty, the total value of the + transaction will be assigned to the value defined by 'tgFromAcnt'. + Otherwise, the entries specified here will be added to the credit side + of this transaction, and their sum value will be subtracted from the + total value of the transaction and assigned to 'tgFromAcnt'. + + This is useful for situations where a particular transaction denotes + values that come from multiple subaccounts. + -} + List FromEntryGetter.Type + , tgToEntries : {- 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 + List ToEntryGetter.Type } let StatementParser_ = @@ -1051,7 +1077,8 @@ in { CurID , Field , FieldMap , Entry - , EntryGetter + , FromEntryGetter + , ToEntryGetter , EntryTextGetter , EntryCurGetter , EntryAcntGetter diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index ea29dbf..3533dd4 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -421,9 +421,13 @@ data History | HistStatement !Statement deriving (Eq, Generic, Hashable, FromDhall) -type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID +type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID -instance FromDhall EntryGetter +type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID + +instance FromDhall ToEntryGetter + +instance FromDhall FromEntryGetter deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t) @@ -440,10 +444,6 @@ data Tx s = Tx } deriving (Generic) -type ExpTx = Tx EntryGetter - -instance FromDhall ExpTx - data TxOpts re = TxOpts { toDate :: !T.Text , toAmount :: !T.Text @@ -504,9 +504,10 @@ data FieldMatcher re deriving instance Show (FieldMatcher T.Text) data TxGetter = TxGetter - { tgCurrency :: !EntryCur - , tgAcnt :: !EntryAcnt - , tgEntries :: ![EntryGetter] + { tgFromAcnt :: !EntryAcnt + , tgFromCurrency :: !EntryCur + , tgFromEntries :: ![FromEntryGetter] + , tgToEntries :: ![ToEntryGetter] } deriving (Eq, Generic, Hashable, Show, FromDhall) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 3be6ee7..81c2636 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -129,6 +129,8 @@ accountSign EquityT = Credit type RawEntry = Entry AcntID (Maybe Rational) CurID TagID +type RawFromEntry = Entry AcntID Rational CurID TagID + type BalEntry = Entry AcntID Rational CurID TagID type RawTx = Tx RawEntry diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index fcca4d1..9b55cf0 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -304,28 +304,41 @@ 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 cur a ss) = MatchPass <$> toTx cur a ss r + convert TxGetter {tgFromAcnt, tgFromCurrency, tgFromEntries, tgToEntries} = + MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r -toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx -toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do - combineError3 acntRes curRes ssRes $ \a c es -> - let fromEntry = - Entry - { eAcnt = a - , eCurrency = c - , eValue = Just trAmount - , eComment = "" - , eTags = [] -- TODO what goes here? +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) -> + let fromValue = trAmount - sum (fmap eValue fs) + fromEntry = + Entry + { eAcnt = a + , eCurrency = c + , eValue = Just fromValue + , eComment = "" + , eTags = [] -- TODO what goes here? + } + in Tx + { txDate = trDate + , txDescr = trDesc + , txEntries = fromEntry : fmap liftEntry fs ++ ts } - in Tx - { txDate = trDate - , txDescr = trDesc - , txEntries = fromEntry : es - } where acntRes = liftInner $ resolveAcnt r sa curRes = liftInner $ resolveCurrency r sc - ssRes = combineErrors $ fmap (resolveEntry r) toEntries + fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries + toRes = combineErrors $ fmap (resolveToEntry r) toEntries + liftEntry e = e {eValue = Just $ eValue e} valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x @@ -351,8 +364,20 @@ otherMatches dict m = case m of where lookup_ t n = lookupErr (MatchField t) n dict -resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry -resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do +resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry +resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do + m <- ask + liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do + v' <- roundPrecisionCur c m v + return $ s {eAcnt = a, eValue = v', eCurrency = c} + where + acntRes = resolveAcnt r eAcnt + curRes = resolveCurrency r eCurrency + 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