ENH clean up (and hopefully fix) lots of balancing stuff

This commit is contained in:
Nathan Dwarshuis 2023-07-05 22:30:24 -04:00
parent d9709f565f
commit dce3ff4166
3 changed files with 211 additions and 242 deletions

View File

@ -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) =

View File

@ -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
--------------------------------------------------------------------------------

View File

@ -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
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
return (fs ++ ts)
where
(rs, ls) = case utFrom0 of
Left x -> (x : utFromRO, utFromUnk)
Right x -> (utFromRO, x : utFromUnk)
(tpairs, fs) <-
fmap partitionEithers $
foldM goFrom [] $
bc = (utCurrency, utBudget)
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 $
(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))
(Left <$> ro) ++ (Right <$> linked)
return (tot, fs, tpairs)
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
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' = 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 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, utCurrency, utBudget) v
modify $ mapAdd_ (ueAcnt e, k) v
return v
updateUnknown e = do
let key = (ueAcnt e, utCurrency, utBudget)
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
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
entrySum = sum . fmap ueValue
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)
--------------------------------------------------------------------------------
-- 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'
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''
, 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, [])