diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 742b49f..2b1c7e5 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -411,6 +411,35 @@ let EntryNumGetter = | BalanceN : 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, lngIndex = 0 } + } + +let LinkedEntryNumGetter = + {- + Means to get a numeric value from a statement row or another entry getter. + + Linked: a number referring to the entry on the 'from' side of the + transaction (with 0 being the primary entry) + Getter: a normal getter + -} + < Linked : LinkedNumGetter.Type | Getter : EntryNumGetter > + let EntryTextGetter = {- Means to get a textual value from a statement row. @@ -473,115 +502,100 @@ let Entry = let EntryGetter = {- - Means for getting an entry from a given row in a statement + Means for getting an entry from a given row in a statement (debit side) -} - { Type = Entry EntryAcntGetter EntryNumGetter TagID - , default = { eComment = "", eTags = [] : List TagID } - } + \(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 TxSubGetter = {- A means for transforming one row in a statement to a transaction -} { Type = - { tsgFromAcnt : EntryAcntGetter - , tsgToAcnt : EntryAcntGetter - , tsgValue : EntryNumGetter + { tsgValue : EntryNumGetter , tsgCurrency : EntryCurGetter - , tsgFromEntries : List EntryGetter.Type - , tsgFromComment : Text - , tsgToComment : Text - , tsgFromTags : List TagID - , tsgToTags : List TagID - , tsgToEntries : List EntryGetter.Type + , tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type + , tsgTo : (TxHalfGetter ToEntryGetter.Type).Type } - , default = - { tsgFromTags = [] : List TagID - , tsgToTags = [] : List TagID - , tsgFromComment = "" - , tsgToComment = "" - , tsgFromEntries = [] : List EntryGetter.Type - , tsgToEntries = [] : List EntryGetter.Type - } + , default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter } } let TxGetter = {- A means for transforming one row in a statement to a transaction - - 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. - -} { Type = - { 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 - , 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 - , tgFromComment : Text - , tgToComment : Text - , tgFromTags : List TagID - , tgToTags : List TagID - , tgCurrency : - {- - 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 EntryGetter.Type - , tgToEntries : - {- - A means of getting entries for this transaction - -} - List EntryGetter.Type - , tgOtherEntries : - {- - -} - List TxSubGetter.Type + { tgFrom : (TxHalfGetter FromEntryGetter.Type).Type + , tgTo : (TxHalfGetter ToEntryGetter.Type).Type + , tgCurrency : EntryCurGetter + , tgOtherEntries : List TxSubGetter.Type } , default = { tgOtherEntries = [] : List TxSubGetter.Type - , tgFromTags = [] : List TagID - , tgToTags = [] : List TagID - , tgFromEntries = [] : List EntryGetter.Type - , tgToEntries = [] : List EntryGetter.Type - , tgFromComment = "" - , tgToComment = "" + , tsgFrom = TxHalfGetter + , tsgTo = TxHalfGetter } } @@ -1128,10 +1142,13 @@ in { CurID , FieldMatcher , FieldMatcher_ , EntryNumGetter + , LinkedEntryNumGetter + , LinkedNumGetter , Field , FieldMap , Entry - , EntryGetter + , FromEntryGetter + , ToEntryGetter , EntryTextGetter , EntryCurGetter , EntryAcntGetter diff --git a/dhall/common.dhall b/dhall/common.dhall index 0f2a6e2..432790a 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -7,7 +7,7 @@ let T = ./Types.dhall let nullEntry = \(a : T.EntryAcntGetter) -> \(v : T.EntryNumGetter) -> - T.EntryGetter::{ eAcnt = a, eValue = v } + T.FromEntryGetter::{ eAcnt = a, eValue = v } let nullOpts = T.TxOpts::{=} @@ -99,7 +99,7 @@ let partN = (T.EntryNumGetter.ConstN x._2) // { eComment = x._3 } - in List/map PartEntry T.EntryGetter.Type toEntry ss + in List/map PartEntry T.FromEntryGetter.Type toEntry ss let addDay = \(x : T.GregorianM) -> diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index a87b65d..3b481c6 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -69,7 +69,7 @@ readHistStmt readHistStmt root i = whenHash_ CTImport i $ do bs <- readImport root i bounds <- askDBState kmStatementInterval - return $ filter (inDaySpan bounds . dtxDate) bs + return $ filter (inDaySpan bounds . txDate) bs splitHistory :: [History] -> ([HistTransfer], [Statement]) splitHistory = partitionEithers . fmap go @@ -101,16 +101,14 @@ txPair -> DeferredTx txPair day from to cur val desc = Tx - { dtxDescr = desc - , dtxDate = day - , dtxEntries = + { txDescr = desc + , txDate = day + , txEntries = [ EntrySet - { desTotalValue = -val - , desCurrency = cur - , desFromEntry0 = entry from - , desToEntryBal = entry to - , desFromEntries = [] - , desToEntries = [] + { esTotalValue = -val + , esCurrency = cur + , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} + , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} } ] } @@ -124,11 +122,11 @@ txPair day from to cur val desc = } resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx -resolveTx t@Tx {dtxEntries = ss} = - (\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss +resolveTx t@Tx {txEntries = ss} = + (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () -insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do +insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do k <- insert $ TransactionR c d e mapM_ (insertEntry k) ss @@ -337,56 +335,75 @@ balanceTxs => [(CommitR, DeferredTx)] -> m [(CommitR, KeyTx)] balanceTxs ts = do - keyts <- mapErrors resolveTx $ snd $ L.mapAccumL go M.empty ts' + keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty return $ zip cs keyts where - (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 + (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts + go t@Tx {txEntries} = + (\es -> t {txEntries = concat es}) <$> mapM balanceEntrySet txEntries type EntryBals = M.Map (AcntID, CurID) Rational -- 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 + :: (MonadInsertError m, MonadFinance m) + => DeferredEntrySet + -> StateT EntryBals m [BalEntry] +balanceEntrySet EntrySet - { desFromEntry0 - , desFromEntries - , desToEntryBal - , desToEntries - , desCurrency - , desTotalValue - } = flipTup $ runState doBalAll bals + { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} + , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} + , esCurrency + , esTotalValue + } = + do + let (lts, dts) = partitionEithers $ splitLinked <$> ts + fs' <- doEntries fs esTotalValue f0 + let fv = V.fromList $ fmap eValue fs' + lts' <- lift $ mapErrors (resolveLinked fv esCurrency) lts + ts' <- doEntries (dts ++ lts') (-esTotalValue) t0 + return $ toFull <$> fs' ++ ts' where - flipTup (a, b) = (b, a) doEntries es tot e0 = do - es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es) + es' <- liftInnerS $ mapM (balanceEntry esCurrency) es let val0 = tot - entrySum es' - modify $ mapAdd_ (eAcnt e0, desCurrency) val0 + modify $ mapAdd_ (eAcnt e0, esCurrency) 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} + toFull e = FullEntry {feEntry = e, feCurrency = esCurrency} + splitLinked e@Entry {eValue} = case eValue of + LinkIndex l -> Left e {eValue = l} + LinkDeferred d -> Right e {eValue = d} + liftInnerS = mapStateT (return . runIdentity) + +resolveLinked + :: (MonadInsertError m, MonadFinance m) + => Vector Rational + -> CurID + -> Entry a LinkedNumGetter t + -> m (Entry a (Deferred Rational) t) +resolveLinked from cur e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do + curMap <- askDBState kmCurrency + case from V.!? fromIntegral lngIndex of + Nothing -> throwError undefined + Just v -> do + v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v + return $ e {eValue = Deferred False v'} 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} = - (mapAdd_ key newVal bals, e {eValue = newVal}) + -> State EntryBals (Entry AcntID Rational TagID) +balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do + curBal <- gets (M.findWithDefault 0 key) + let newVal = if toBal then v - curBal else v + modify (mapAdd_ key newVal) + return $ e {eValue = newVal} where key = (eAcnt, curID) - curBal = M.findWithDefault 0 key bals - newVal = if toBal then v - curBal else v -- -- reimplementation from future version :/ -- mapAccumM diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index a8e0a07..04b5f86 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -33,10 +33,12 @@ 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 "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" @@ -98,6 +100,8 @@ deriveProduct , "BudgetCurrency" , "Exchange" , "EntryNumGetter" + , "LinkedNumGetter" + , "LinkedEntryNumGetter" , "TemporalScope" , "SqlConfig" , "PretaxValue" @@ -340,6 +344,10 @@ 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 @@ -421,9 +429,15 @@ data History | HistStatement !Statement deriving (Eq, Generic, Hashable, FromDhall) -type EntryGetter = Entry EntryAcnt EntryNumGetter TagID +type EntryGetter n = Entry EntryAcnt n TagID -instance FromDhall EntryGetter +type FromEntryGetter = EntryGetter EntryNumGetter + +type ToEntryGetter = EntryGetter LinkedEntryNumGetter + +instance FromDhall FromEntryGetter + +instance FromDhall ToEntryGetter deriving instance (Show a, Show v, Show t) => Show (Entry a v t) @@ -492,30 +506,30 @@ 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 - { tsgFromAcnt :: !EntryAcnt - , tsgToAcnt :: !EntryAcnt - , tsgFromComment :: !T.Text - , tsgToComment :: !T.Text - , tsgFromTags :: ![TagID] - , tsgToTags :: ![TagID] + { tsgFrom :: !(TxHalfGetter FromEntryGetter) + , tsgTo :: !(TxHalfGetter ToEntryGetter) , tsgValue :: !EntryNumGetter , tsgCurrency :: !EntryCur - , tsgFromEntries :: ![EntryGetter] - , tsgToEntries :: ![EntryGetter] } deriving (Eq, Generic, Hashable, Show, FromDhall) data TxGetter = TxGetter - { tgFromAcnt :: !EntryAcnt - , tgToAcnt :: !EntryAcnt - , tgFromComment :: !T.Text - , tgToComment :: !T.Text - , tgFromTags :: ![TagID] - , tgToTags :: ![TagID] + { tgFrom :: !(TxHalfGetter FromEntryGetter) + , tgTo :: !(TxHalfGetter ToEntryGetter) , tgCurrency :: !EntryCur - , tgFromEntries :: ![EntryGetter] - , tgToEntries :: ![EntryGetter] , tgOtherEntries :: ![TxSubGetter] } deriving (Eq, Generic, Hashable, Show, FromDhall) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index e4be06e..4495db2 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -138,23 +138,26 @@ accountSign IncomeT = Credit accountSign LiabilityT = Credit accountSign EquityT = Credit +data HalfEntrySet a c t v = HalfEntrySet + { hesPrimary :: !(Entry a () t) + , hesOther :: ![Entry a v t] + } + 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) + { esTotalValue :: !Rational + , esCurrency :: !c + , esFrom :: !(HalfEntrySet a c t (Deferred v)) + , esTo :: !(HalfEntrySet a c t (LinkDeferred v)) } data Tx e = Tx - { dtxDescr :: !T.Text - , dtxDate :: !Day - , dtxEntries :: !e + { txDescr :: !T.Text + , txDate :: !Day + , txEntries :: !e } deriving (Generic) -type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational) +type DeferredEntrySet = EntrySet AcntID CurID TagID Rational type BalEntrySet = EntrySet AcntID CurID TagID Rational @@ -169,6 +172,11 @@ type KeyTx = Tx [KeyEntry] data Deferred a = Deferred Bool a deriving (Show, Functor, Foldable, Traversable) +data LinkDeferred a + = LinkDeferred (Deferred a) + | LinkIndex LinkedNumGetter + deriving (Show, Functor, Foldable, Traversable) + -- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index c902370..af8ca25 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -310,105 +310,131 @@ matches toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx toTx TxGetter - { tgFromAcnt - , tgToAcnt - , tgFromComment - , tgToComment - , tgFromTags - , tgToTags + { tgFrom + , tgTo , tgCurrency - , tgFromEntries - , tgToEntries , tgOtherEntries } r@TxRecord {trAmount, trDate, trDesc} = do - combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> + combineError curRes subRes $ \(cur, f, t) ss -> Tx - { dtxDate = trDate - , dtxDescr = trDesc - , dtxEntries = + { txDate = trDate + , txDescr = trDesc + , txEntries = EntrySet - { desTotalValue = trAmount - , desCurrency = cur - , desFromEntry0 = entry0 fa tgFromComment tgFromTags - , desFromEntries = fe - , desToEntries = te - , desToEntryBal = entry0 ta tgToComment tgToTags + { esTotalValue = trAmount + , esCurrency = cur + , esFrom = f + , esTo = t } : ss } where - 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,,) + let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom + let toRes = resolveHalfEntry resolveToValue cur r tgTo + combineError fromRes toRes (cur,,) subRes = mapErrors (resolveSubGetter r) tgOtherEntries - entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts} resolveSubGetter :: TxRecord -> TxSubGetter - -> InsertExceptT CurrencyM DeferredEntrySet -resolveSubGetter - r - TxSubGetter - { tsgFromAcnt - , tsgToAcnt - , tsgFromTags - , tsgToTags - , tsgFromComment - , tsgToComment - , 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 = tsgFromComment - , eTags = tsgFromTags - } - let toEntry = - Entry - { eAcnt = ta - , eValue = () - , eComment = tsgToComment - , eTags = tsgToTags - } - 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,,) + -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational) +resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do + m <- ask + cur <- liftInner $ resolveCurrency r tsgCurrency + (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue + let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom + let toRes = resolveHalfEntry resolveToValue cur r tsgTo + combineError fromRes toRes $ \f t -> + EntrySet + { esTotalValue = val + , esCurrency = cur + , esFrom = f + , esTo = t + } + +resolveHalfEntry + :: Traversable f + => (TxRecord -> n -> InsertExcept (f Double)) + -> CurID + -> TxRecord + -> TxHalfGetter (EntryGetter n) + -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational)) +resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = + combineError acntRes esRes $ \a es -> + HalfEntrySet + { hesPrimary = + Entry + { eAcnt = a + , eValue = () + , eComment = thgComment + , eTags = thgTags + } + , hesOther = es + } + where + acntRes = liftInner $ resolveAcnt r thgAcnt + esRes = mapErrors (resolveEntry f cur r) thgEntries + +-- resolveSubGetter +-- :: TxRecord +-- -> TxSubGetter +-- -> InsertExceptT CurrencyM DeferredEntrySet +-- resolveSubGetter +-- r +-- TxSubGetter +-- { tsgFromAcnt +-- , tsgToAcnt +-- , tsgFromTags +-- , tsgToTags +-- , tsgFromComment +-- , tsgToComment +-- , 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 = tsgFromComment +-- , eTags = tsgFromTags +-- } +-- let toEntry = +-- Entry +-- { eAcnt = ta +-- , eValue = () +-- , eComment = tsgToComment +-- , eTags = tsgToTags +-- } +-- 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 @@ -434,20 +460,35 @@ otherMatches dict m = case m of where lookup_ t n = lookupErr (MatchField t) n dict --- TODO this should be more general? resolveEntry - :: CurID + :: Traversable f + => (TxRecord -> n -> InsertExcept (f Double)) + -> CurID -> TxRecord - -> EntryGetter - -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID) -resolveEntry cur r s@Entry {eAcnt, eValue} = do + -> EntryGetter n + -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID) +resolveEntry f cur r s@Entry {eAcnt, eValue} = do m <- ask liftInner $ combineErrorM acntRes valRes $ \a v -> do v' <- mapM (roundPrecisionCur cur m) v return $ s {eAcnt = a, eValue = v'} where acntRes = resolveAcnt r eAcnt - valRes = resolveValue r eValue + valRes = f r eValue + +-- resolveEntry +-- :: CurID +-- -> TxRecord +-- -> EntryGetter n +-- -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID) +-- resolveEntry cur r s@Entry {eAcnt, eValue} = do +-- m <- ask +-- liftInner $ combineErrorM acntRes valRes $ \a v -> do +-- v' <- mapM (roundPrecisionCur cur m) v +-- return $ s {eAcnt = a, eValue = v'} +-- where +-- acntRes = resolveAcnt r eAcnt +-- valRes = resolveValue r eValue -- curRes = resolveCurrency r eCurrency @@ -556,19 +597,21 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) collectErrorsIO = mapErrorsIO id -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 +resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double) +resolveFromValue r = fmap (uncurry Deferred) . resolveValue r --- -- 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 +resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) +resolveToValue _ (Linked l) = return $ LinkIndex l +resolveToValue r (Getter g) = do + (l, v) <- resolveValue r g + return $ LinkDeferred (Deferred l v) + +resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double) +resolveValue TxRecord {trOther, trAmount} s = case s of + (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther) + (ConstN c) -> return (False, c) + AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount + BalanceN x -> return (True, x) resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt = resolveEntryField AcntField