From dce3ff4166228610f7fac7578154a7ed63968884 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 5 Jul 2023 22:30:24 -0400 Subject: [PATCH] ENH clean up (and hopefully fix) lots of balancing stuff --- lib/Internal/Database.hs | 56 +++--- lib/Internal/Types/Main.hs | 15 +- lib/Internal/Utils.hs | 382 +++++++++++++++++-------------------- 3 files changed, 211 insertions(+), 242 deletions(-) diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index b4d3199..a0472f4 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -422,21 +422,6 @@ whenHash_ t o f = do hs <- askDBState kmNewCommits if h `elem` hs then Just . (c,) <$> f else return Nothing --- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry --- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do --- let aRes = lookupAccountKey eAcnt --- let cRes = lookupCurrencyKey feCurrency --- 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 --- { feCurrency = cid --- , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags} --- } - readUpdates :: (MonadInsertError m, MonadSqlQuery m) => [Int] @@ -584,24 +569,41 @@ splitTo from0 fromUnk (t0 :| ts) = do primary = uncurry makeUnkUE t0 splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e --- ASSUME from and toLinked are sorted according to index and 'fst' respectively +-- | 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 :: [UEUnk] -> [(Int, NonEmpty (EntryRId, EntryR))] -> InsertExcept ([(UEUnk, [UELink])], [UE_RO]) zipPaired = go ([], []) where - go (facc, tacc) (f : fs) ((ti, tls) : ts) - | ueIndex f == ti = do - tls' <- mapErrors makeLinkUnk tls - go ((f, NE.toList tls') : facc, tacc) fs ts - | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts - go (facc, tacc) fs ts = - return - ( reverse facc ++ ((,[]) <$> fs) - , tacc ++ concatMap (toRO . snd) ts - ) - toRO = NE.toList . fmap (makeRoUE . snd) + 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 . snd <$> tls + let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink + go (f acc') fs' ts + +-- go (facc, tacc) (f : fs) ((ti, tls) : ts) +-- | ueIndex f == ti = do +-- tls' <- mapErrors makeLinkUnk tls +-- go ((f, NE.toList tls') : facc, tacc) fs ts +-- | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts +-- go (facc, tacc) fs ts = +-- return +-- ( reverse facc ++ ((,[]) <$> fs) +-- , tacc ++ concatMap (toRO . snd) ts +-- ) makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink makeLinkUnk (k, e) = diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 42964f9..bc2e868 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -60,6 +60,7 @@ data DBUpdates = DBUpdates , duNewAcntIds :: ![Entity AccountR] , duNewCurrencyIds :: ![Entity CurrencyR] } + deriving (Show) type CurrencyM = Reader CurrencyMap @@ -135,10 +136,6 @@ data EntryBin | ToRead ReadEntry | ToInsert (Tx CommitR) -type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId - -type BalEntry = InsertEntry AcntID CurID TagID - type TreeR = Tree ([T.Text], AccountRId) type MonadFinance = MonadReader DBState @@ -255,15 +252,15 @@ data Tx k = Tx } deriving (Generic, Show) -data InsertEntry a c t = InsertEntry +data InsertEntry = InsertEntry { ieDeferred :: !(Maybe DBDeferred) - , ieEntry :: !(Entry a Rational t) + , ieEntry :: !(Entry AccountRId Rational TagRId) } data InsertEntrySet = InsertEntrySet { iesCurrency :: !CurrencyRId - , iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) - , iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) + , iesFromEntries :: !(NonEmpty InsertEntry) + , iesToEntries :: !(NonEmpty InsertEntry) } data InsertTx = InsertTx @@ -290,8 +287,6 @@ data LinkDeferred a -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID --- type BalEntry = InsertEntry AcntID CurID TagID - data MatchRes a = MatchPass !a | MatchFail | MatchSkip -------------------------------------------------------------------------------- diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 742c660..b156ea6 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -677,7 +677,6 @@ lookupFinance -> m a lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f --- TODO need to split out the balance map by budget name (epic facepalm) balanceTxs :: (MonadInsertError m, MonadFinance m) => [EntryBin] @@ -691,7 +690,7 @@ balanceTxs ebs = liftInnerS $ either rebalanceTotalEntrySet rebalanceFullEntrySet utx go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do - modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue + modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue return Nothing go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary @@ -715,18 +714,20 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToInsert Tx {txDate}) = txDate -type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational +type BCKey = (CurrencyRId, Text) -data UpdateEntryType a b - = UET_ReadOnly UE_RO - | UET_Unk a - | UET_Linked b +type ABCKey = (AccountRId, BCKey) + +type EntryBals = M.Map ABCKey Rational + +-------------------------------------------------------------------------------- +-- rebalancing -- TODO make sure new values are rounded properly here rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceTotalEntrySet UpdateEntrySet - { utFrom0 = (f0, f0links) + { utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links) , utTo0 , utFromUnk , utToUnk @@ -737,64 +738,14 @@ rebalanceTotalEntrySet , utBudget } = do - (f0val, (tpairs, fs)) <- - fmap (second partitionEithers) $ - foldM goFrom (utTotalValue, []) $ - L.sortOn idx $ - (UET_ReadOnly <$> utFromRO) - ++ (UET_Linked <$> utFromUnk) - let f0' = f0 {ueValue = StaticValue f0val} - let tsLink0 = fmap (unlink (-f0val)) f0links - (t0val, tsUnk) <- - fmap (second catMaybes) $ - foldM goTo (-utTotalValue, []) $ - L.sortOn idx2 $ - (UET_Linked <$> (tpairs ++ tsLink0)) - ++ (UET_Unk <$> utToUnk) - ++ (UET_ReadOnly <$> utToRO) - let t0 = utTo0 {ueValue = StaticValue t0val} - return (f0' : fs ++ (t0 : tsUnk)) + (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk + let f0val = utTotalValue - fval + modify $ mapAdd_ (f0Acnt, bc) f0val + let tsLinked = tpairs ++ (unlink f0val <$> f0links) + ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked + return (f0 {ueValue = StaticValue f0val} : fs ++ ts) where - project f _ _ (UET_ReadOnly e) = f e - project _ f _ (UET_Unk e) = f e - project _ _ f (UET_Linked p) = f p - idx = project ueIndex ueIndex (ueIndex . fst) - idx2 = project ueIndex ueIndex ueIndex - -- TODO the sum accumulator thing is kinda awkward - goFrom (tot, es) (UET_ReadOnly e) = do - v <- updateFixed e - return (tot - v, es) - goFrom (tot, esPrev) (UET_Unk e) = do - v <- updateUnknown e - return (tot - v, Right e {ueValue = StaticValue v} : esPrev) - goFrom (tot, esPrev) (UET_Linked (e0, es)) = do - v <- updateUnknown e0 - let e0' = Right $ e0 {ueValue = StaticValue v} - let es' = fmap (Left . unlink (-v)) es - return (tot - v, (e0' : es') ++ esPrev) - goTo (tot, esPrev) (UET_ReadOnly e) = do - v <- updateFixed e - return (tot - v, esPrev) - goTo (tot, esPrev) (UET_Linked e) = do - v <- updateFixed e - return (tot - v, Just e : esPrev) - goTo (tot, esPrev) (UET_Unk e) = do - v <- updateUnknown e - return (tot - v, Just e {ueValue = StaticValue v} : esPrev) - updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational - updateFixed e = do - let v = unStaticValue $ ueValue e - modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v - return v - updateUnknown e = do - let key = (ueAcnt e, utCurrency, utBudget) - curBal <- gets (M.findWithDefault 0 key) - let v = case ueValue e of - EVPercent p -> p * curBal - EVBalance p -> p - curBal - modify $ mapAdd_ key v - return v - unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)} + bc = (utCurrency, utBudget) rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceFullEntrySet @@ -809,108 +760,92 @@ rebalanceFullEntrySet , utBudget } = do - let (f_ro, f_lnkd) = case utFrom0 of - Left x -> (x : utFromRO, utFromUnk) - Right x -> (utFromRO, x : utFromUnk) - (tpairs, fs) <- - fmap partitionEithers $ - foldM goFrom [] $ - L.sortOn idx $ - (UET_ReadOnly <$> f_ro) - ++ (UET_Linked <$> f_lnkd) - tsUnk <- - fmap catMaybes $ - foldM goTo [] $ - L.sortOn idx2 $ - (UET_Linked <$> tpairs) - ++ (UET_Unk <$> utToUnk) - ++ (UET_ReadOnly <$> utToRO) - let t0val = -(entrySum fs + entrySum tsUnk) - let t0 = utTo0 {ueValue = t0val} - return (fs ++ (t0 : tsUnk)) + (ftot, fs, tpairs) <- rebalanceDebit bc rs ls + ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs + return (fs ++ ts) where - project f _ _ (UET_ReadOnly e) = f e - project _ f _ (UET_Unk e) = f e - project _ _ f (UET_Linked p) = f p - idx = project ueIndex ueIndex (ueIndex . fst) - idx2 = project ueIndex ueIndex ueIndex - -- TODO the sum accumulator thing is kinda awkward - goFrom es (UET_ReadOnly e) = do - _ <- updateFixed e - return es - goFrom esPrev (UET_Unk e) = do - v <- updateUnknown e - return $ Right e {ueValue = StaticValue v} : esPrev - goFrom esPrev (UET_Linked (e0, es)) = do - v <- updateUnknown e0 - let e0' = Right $ e0 {ueValue = StaticValue v} - let es' = fmap (Left . unlink (-v)) es - return $ (e0' : es') ++ esPrev - goTo esPrev (UET_ReadOnly e) = do - _ <- updateFixed e - return esPrev - goTo esPrev (UET_Linked e) = do - _ <- updateFixed e - return $ Just e : esPrev - goTo esPrev (UET_Unk e) = do - v <- updateUnknown e - return $ Just e {ueValue = StaticValue v} : esPrev - updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational - updateFixed e = do - let v = unStaticValue $ ueValue e - modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v - return v - updateUnknown e = do - let key = (ueAcnt e, utCurrency, utBudget) - curBal <- gets (M.findWithDefault 0 key) - let v = case ueValue e of - EVPercent p -> p * curBal - EVBalance p -> p - curBal - modify $ mapAdd_ key v - return v - unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)} - entrySum = sum . fmap ueValue + (rs, ls) = case utFrom0 of + Left x -> (x : utFromRO, utFromUnk) + Right x -> (utFromRO, x : utFromUnk) + bc = (utCurrency, utBudget) -balanceSecondaryEntrySet - :: (MonadInsertError m, MonadFinance m) - => T.Text - -> SecondayEntrySet - -> StateT EntryBals m InsertEntrySet -balanceSecondaryEntrySet - budgetName - EntrySet - { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} - , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} - , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} - } = - do - fs' <- mapErrors resolveAcntAndTags (f0 :| fs) - t0' <- resolveAcntAndTags t0 - ts' <- mapErrors resolveAcntAndTags ts - let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName - fs'' <- mapErrors balFromEntry fs' - let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs'' - let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName - ts'' <- mapErrors balToEntry ts' - -- TODO wet - let (acntID, sign) = eAcnt t0' - let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'') - modify (mapAdd_ (acntID, curID, budgetName) t0Val) - let t0'' = - InsertEntry - { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID} - , ieDeferred = Nothing - } - -- TODO don't record index here, just keep them in order and let the - -- insertion function deal with assigning the index - return $ - InsertEntrySet - { iesCurrency = curID - , iesFromEntries = fs'' - , iesToEntries = t0'' :| ts'' - } - where - entrySum = sum . fmap (eValue . ieEntry) +rebalanceDebit + :: BCKey + -> [UE_RO] + -> [(UEUnk, [UELink])] + -> State EntryBals (Rational, [UEBalanced], [UEBalanced]) +rebalanceDebit k ro linked = do + (tot, (tpairs, fs)) <- + fmap (second (partitionEithers . concat)) $ + sumM goFrom $ + L.sortOn idx $ + (Left <$> ro) ++ (Right <$> linked) + return (tot, fs, tpairs) + where + idx = either ueIndex (ueIndex . fst) + goFrom (Left e) = (,[]) <$> updateFixed k e + goFrom (Right (e0, es)) = do + v <- updateUnknown k e0 + let e0' = Right $ e0 {ueValue = StaticValue v} + let es' = Left . unlink v <$> es + return (v, e0' : es') + +unlink :: Rational -> UELink -> UEBalanced +unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)} + +rebalanceCredit + :: BCKey + -> Rational + -> UEBlank + -> [UEUnk] + -> [UE_RO] + -> [UEBalanced] + -> State EntryBals [UEBalanced] +rebalanceCredit k tot t0 us rs bs = do + (tval, ts) <- + fmap (second catMaybes) $ + sumM goTo $ + L.sortOn idx $ + (UETLinked <$> bs) + ++ (UETUnk <$> us) + ++ (UETReadOnly <$> rs) + return (t0 {ueValue = StaticValue (-(tot + tval))} : ts) + where + idx = projectUET ueIndex ueIndex ueIndex + goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e + goTo (UETLinked e) = (,Just e) <$> updateFixed k e + goTo (UETUnk e) = do + v <- updateUnknown k e + return (v, Just $ e {ueValue = StaticValue v}) + +data UpdateEntryType a b + = UETReadOnly UE_RO + | UETUnk a + | UETLinked b + +projectUET :: (UE_RO -> c) -> (a -> c) -> (b -> c) -> UpdateEntryType a b -> c +projectUET f _ _ (UETReadOnly e) = f e +projectUET _ f _ (UETUnk e) = f e +projectUET _ _ f (UETLinked p) = f p + +updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Rational +updateFixed k e = do + let v = unStaticValue $ ueValue e + modify $ mapAdd_ (ueAcnt e, k) v + return v + +updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational +updateUnknown k e = do + let key = (ueAcnt e, k) + curBal <- gets (M.findWithDefault 0 key) + let v = case ueValue e of + EVPercent p -> p * curBal + EVBalance p -> p - curBal + modify $ mapAdd_ key v + return v + +-------------------------------------------------------------------------------- +-- balancing balancePrimaryEntrySet :: (MonadInsertError m, MonadFinance m) @@ -930,37 +865,72 @@ balancePrimaryEntrySet let t0res = resolveAcntAndTags t0 let fsres = mapErrors resolveAcntAndTags fs let tsres = mapErrors resolveAcntAndTags ts + let bc = (curID, budgetName) combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ \(f0', fs') (t0', ts') -> do - let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName - fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs' + let balFrom = fmap liftInnerS . balanceDeferred + fs'' <- doEntries balFrom bc esTotalValue f0' fs' + balanceFinal bc (-esTotalValue) precision fs'' t0' ts' - let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs'' +balanceSecondaryEntrySet + :: (MonadInsertError m, MonadFinance m) + => T.Text + -> SecondayEntrySet + -> StateT EntryBals m InsertEntrySet +balanceSecondaryEntrySet + budgetName + EntrySet + { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} + , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} + , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} + } = + do + let fsRes = mapErrors resolveAcntAndTags (f0 :| fs) + let t0Res = resolveAcntAndTags t0 + let tsRes = mapErrors resolveAcntAndTags ts + combineErrorM fsRes (combineError t0Res tsRes (,)) $ \fs' (t0', ts') -> do + fs'' <- mapErrors balFrom fs' + let tot = entrySum (NE.toList fs'') + balanceFinal bc (-tot) precision fs'' t0' ts' + where + entrySum = sum . fmap (eValue . ieEntry) + balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc + bc = (curID, budgetName) - let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName - ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts' - return $ - InsertEntrySet - { iesCurrency = curID - , iesFromEntries = fs'' - , iesToEntries = ts'' - } +balanceFinal + :: (MonadInsertError m) + => BCKey + -> Rational + -> Natural + -> NonEmpty InsertEntry + -> Entry (AccountRId, AcntSign) () TagRId + -> [Entry (AccountRId, AcntSign) (LinkDeferred Rational) TagRId] + -> StateT EntryBals m InsertEntrySet +balanceFinal k@(curID, _) tot precision fs t0 ts = do + let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs + let balTo = balanceLinked fv precision + ts' <- doEntries balTo k tot t0 ts + return $ + InsertEntrySet + { iesCurrency = curID + , iesFromEntries = fs + , iesToEntries = ts' + } doEntries :: (MonadInsertError m) - => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) - -> CurrencyRId - -> T.Text + => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) + -> BCKey -> Rational -> Entry (AccountRId, AcntSign) () TagRId -> [Entry (AccountRId, AcntSign) v TagRId] - -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) -doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do - es' <- mapErrors f es + -> StateT EntryBals m (NonEmpty InsertEntry) +doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do + es' <- mapErrors (balanceEntry f k) es let e0val = tot - entrySum es' -- TODO not dry let s = fromIntegral $ sign2Int sign -- NOTE hack - modify (mapAdd_ (acntID, curID, budgetName) e0val) + modify (mapAdd_ (acntID, k) e0val) let e' = InsertEntry { ieEntry = e {eValue = s * e0val, eAcnt = acntID} @@ -976,13 +946,11 @@ liftInnerS = mapStateT (return . runIdentity) balanceLinked :: MonadInsertError m => Vector Rational - -> CurrencyRId - -> T.Text -> Natural - -> AccountRId + -> ABCKey -> LinkDeferred Rational -> StateT EntryBals m (Rational, Maybe DBDeferred) -balanceLinked from curID budgetName precision acntID lg = case lg of +balanceLinked from precision k lg = case lg of (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex case res of @@ -990,18 +958,16 @@ balanceLinked from curID budgetName precision acntID lg = case lg of -- TODO this error would be much more informative if I had access to the -- file from which it came Nothing -> throwError undefined - (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID budgetName d + (LinkDeferred d) -> liftInnerS $ balanceDeferred k d where go s = negate . roundPrecision precision . (* s) . fromRational balanceDeferred - :: CurrencyRId - -> AccountRId - -> T.Text + :: ABCKey -> EntryValue Rational -> State EntryBals (Rational, Maybe DBDeferred) -balanceDeferred curID acntID budgetName (EntryValue t v) = do - newval <- findBalance acntID curID budgetName t v +balanceDeferred k (EntryValue t v) = do + newval <- findBalance k t v let d = case t of TFixed -> Nothing TBalance -> Just $ EntryBalance v @@ -1010,15 +976,14 @@ balanceDeferred curID acntID budgetName (EntryValue t v) = do balanceEntry :: (MonadInsertError m) - => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) - -> CurrencyRId - -> T.Text + => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) + -> BCKey -> Entry (AccountRId, AcntSign) v TagRId - -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId) -balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do + -> StateT EntryBals m InsertEntry +balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do let s = fromIntegral $ sign2Int sign - (newVal, deferred) <- f acntID eValue - modify (mapAdd_ (acntID, curID, budgetName) newVal) + (newVal, deferred) <- f (acntID, k) eValue + modify (mapAdd_ (acntID, k) newVal) return $ InsertEntry { ieEntry = e {eValue = s * newVal, eAcnt = acntID} @@ -1036,19 +1001,20 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags} findBalance - :: AccountRId - -> CurrencyRId - -> T.Text + :: ABCKey -> TransferType -> Rational -> State EntryBals Rational -findBalance acnt cur name t v = do - curBal <- gets (M.findWithDefault 0 (acnt, cur, name)) +findBalance k t v = do + curBal <- gets (M.findWithDefault 0 k) return $ case t of TBalance -> v - curBal TPercent -> v * curBal TFixed -> v +-------------------------------------------------------------------------------- +-- transfers + expandTransfers :: (MonadInsertError m, MonadFinance m) => CommitR @@ -1122,3 +1088,9 @@ withDates withDates bounds dp f = do days <- liftExcept $ expandDatePat bounds dp combineErrors $ fmap f days + +sumM :: (Monad m, Num s) => (a -> m (s, b)) -> [a] -> m (s, [b]) +sumM f = mapAccumM (\s -> fmap (first (+ s)) . f) 0 + +mapAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b]) +mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])