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 hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing 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 readUpdates
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadInsertError m, MonadSqlQuery m)
=> [Int] => [Int]
@ -584,24 +569,41 @@ splitTo from0 fromUnk (t0 :| ts) = do
primary = uncurry makeUnkUE t0 primary = uncurry makeUnkUE t0
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e 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 zipPaired
:: [UEUnk] :: [UEUnk]
-> [(Int, NonEmpty (EntryRId, EntryR))] -> [(Int, NonEmpty (EntryRId, EntryR))]
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO]) -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired = go ([], []) zipPaired = go ([], [])
where where
go (facc, tacc) (f : fs) ((ti, tls) : ts) nolinks = ((,[]) <$>)
| ueIndex f == ti = do go acc fs [] = return $ first (nolinks fs ++) acc
tls' <- mapErrors makeLinkUnk tls go (facc, tacc) fs ((ti, tls) : ts) = do
go ((f, NE.toList tls') : facc, tacc) fs ts let (lesser, rest) = L.span ((< ti) . ueIndex) fs
| otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts links <- NE.toList <$> mapErrors makeLinkUnk tls
go (facc, tacc) fs ts = let (nextLink, fs') = case rest of
return (r0 : rs)
( reverse facc ++ ((,[]) <$> fs) | ueIndex r0 == ti -> (Just (r0, links), rs)
, tacc ++ concatMap (toRO . snd) ts | otherwise -> (Nothing, rest)
) _ -> (Nothing, rest)
toRO = NE.toList . fmap (makeRoUE . snd) 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 :: (EntryRId, EntryR) -> InsertExcept UELink
makeLinkUnk (k, e) = makeLinkUnk (k, e) =

View File

@ -60,6 +60,7 @@ data DBUpdates = DBUpdates
, duNewAcntIds :: ![Entity AccountR] , duNewAcntIds :: ![Entity AccountR]
, duNewCurrencyIds :: ![Entity CurrencyR] , duNewCurrencyIds :: ![Entity CurrencyR]
} }
deriving (Show)
type CurrencyM = Reader CurrencyMap type CurrencyM = Reader CurrencyMap
@ -135,10 +136,6 @@ data EntryBin
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (Tx CommitR) | ToInsert (Tx CommitR)
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
type BalEntry = InsertEntry AcntID CurID TagID
type TreeR = Tree ([T.Text], AccountRId) type TreeR = Tree ([T.Text], AccountRId)
type MonadFinance = MonadReader DBState type MonadFinance = MonadReader DBState
@ -255,15 +252,15 @@ data Tx k = Tx
} }
deriving (Generic, Show) deriving (Generic, Show)
data InsertEntry a c t = InsertEntry data InsertEntry = InsertEntry
{ ieDeferred :: !(Maybe DBDeferred) { ieDeferred :: !(Maybe DBDeferred)
, ieEntry :: !(Entry a Rational t) , ieEntry :: !(Entry AccountRId Rational TagRId)
} }
data InsertEntrySet = InsertEntrySet data InsertEntrySet = InsertEntrySet
{ iesCurrency :: !CurrencyRId { iesCurrency :: !CurrencyRId
, iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) , iesFromEntries :: !(NonEmpty InsertEntry)
, iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) , iesToEntries :: !(NonEmpty InsertEntry)
} }
data InsertTx = InsertTx data InsertTx = InsertTx
@ -290,8 +287,6 @@ data LinkDeferred a
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type BalEntry = InsertEntry AcntID CurID TagID
data MatchRes a = MatchPass !a | MatchFail | MatchSkip data MatchRes a = MatchPass !a | MatchFail | MatchSkip
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -677,7 +677,6 @@ lookupFinance
-> m a -> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f 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 balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [EntryBin] => [EntryBin]
@ -691,7 +690,7 @@ balanceTxs ebs =
liftInnerS $ liftInnerS $
either rebalanceTotalEntrySet rebalanceFullEntrySet utx either rebalanceTotalEntrySet rebalanceFullEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
return Nothing return Nothing
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
@ -715,18 +714,20 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate binDate (ToInsert Tx {txDate}) = txDate
type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational type BCKey = (CurrencyRId, Text)
data UpdateEntryType a b type ABCKey = (AccountRId, BCKey)
= UET_ReadOnly UE_RO
| UET_Unk a type EntryBals = M.Map ABCKey Rational
| UET_Linked b
--------------------------------------------------------------------------------
-- rebalancing
-- TODO make sure new values are rounded properly here -- TODO make sure new values are rounded properly here
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceTotalEntrySet rebalanceTotalEntrySet
UpdateEntrySet UpdateEntrySet
{ utFrom0 = (f0, f0links) { utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links)
, utTo0 , utTo0
, utFromUnk , utFromUnk
, utToUnk , utToUnk
@ -737,64 +738,14 @@ rebalanceTotalEntrySet
, utBudget , utBudget
} = } =
do do
(f0val, (tpairs, fs)) <- (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
fmap (second partitionEithers) $ let f0val = utTotalValue - fval
foldM goFrom (utTotalValue, []) $ modify $ mapAdd_ (f0Acnt, bc) f0val
L.sortOn idx $ let tsLinked = tpairs ++ (unlink f0val <$> f0links)
(UET_ReadOnly <$> utFromRO) ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
++ (UET_Linked <$> utFromUnk) return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
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))
where where
project f _ _ (UET_ReadOnly e) = f e bc = (utCurrency, utBudget)
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)}
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceFullEntrySet rebalanceFullEntrySet
@ -809,108 +760,92 @@ rebalanceFullEntrySet
, utBudget , utBudget
} = } =
do do
let (f_ro, f_lnkd) = case utFrom0 of (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
Left x -> (x : utFromRO, utFromUnk) ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
Right x -> (utFromRO, x : utFromUnk) return (fs ++ ts)
(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))
where where
project f _ _ (UET_ReadOnly e) = f e (rs, ls) = case utFrom0 of
project _ f _ (UET_Unk e) = f e Left x -> (x : utFromRO, utFromUnk)
project _ _ f (UET_Linked p) = f p Right x -> (utFromRO, x : utFromUnk)
idx = project ueIndex ueIndex (ueIndex . fst) bc = (utCurrency, utBudget)
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
balanceSecondaryEntrySet rebalanceDebit
:: (MonadInsertError m, MonadFinance m) :: BCKey
=> T.Text -> [UE_RO]
-> SecondayEntrySet -> [(UEUnk, [UELink])]
-> StateT EntryBals m InsertEntrySet -> State EntryBals (Rational, [UEBalanced], [UEBalanced])
balanceSecondaryEntrySet rebalanceDebit k ro linked = do
budgetName (tot, (tpairs, fs)) <-
EntrySet fmap (second (partitionEithers . concat)) $
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} sumM goFrom $
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} L.sortOn idx $
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} (Left <$> ro) ++ (Right <$> linked)
} = return (tot, fs, tpairs)
do where
fs' <- mapErrors resolveAcntAndTags (f0 :| fs) idx = either ueIndex (ueIndex . fst)
t0' <- resolveAcntAndTags t0 goFrom (Left e) = (,[]) <$> updateFixed k e
ts' <- mapErrors resolveAcntAndTags ts goFrom (Right (e0, es)) = do
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName v <- updateUnknown k e0
fs'' <- mapErrors balFromEntry fs' let e0' = Right $ e0 {ueValue = StaticValue v}
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs'' let es' = Left . unlink v <$> es
let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName return (v, e0' : es')
ts'' <- mapErrors balToEntry ts'
-- TODO wet unlink :: Rational -> UELink -> UEBalanced
let (acntID, sign) = eAcnt t0' unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
modify (mapAdd_ (acntID, curID, budgetName) t0Val) rebalanceCredit
let t0'' = :: BCKey
InsertEntry -> Rational
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID} -> UEBlank
, ieDeferred = Nothing -> [UEUnk]
} -> [UE_RO]
-- TODO don't record index here, just keep them in order and let the -> [UEBalanced]
-- insertion function deal with assigning the index -> State EntryBals [UEBalanced]
return $ rebalanceCredit k tot t0 us rs bs = do
InsertEntrySet (tval, ts) <-
{ iesCurrency = curID fmap (second catMaybes) $
, iesFromEntries = fs'' sumM goTo $
, iesToEntries = t0'' :| ts'' L.sortOn idx $
} (UETLinked <$> bs)
where ++ (UETUnk <$> us)
entrySum = sum . fmap (eValue . ieEntry) ++ (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 balancePrimaryEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
@ -930,37 +865,72 @@ balancePrimaryEntrySet
let t0res = resolveAcntAndTags t0 let t0res = resolveAcntAndTags t0
let fsres = mapErrors resolveAcntAndTags fs let fsres = mapErrors resolveAcntAndTags fs
let tsres = mapErrors resolveAcntAndTags ts let tsres = mapErrors resolveAcntAndTags ts
let bc = (curID, budgetName)
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
\(f0', fs') (t0', ts') -> do \(f0', fs') (t0', ts') -> do
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName let balFrom = fmap liftInnerS . balanceDeferred
fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs' 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 balanceFinal
ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts' :: (MonadInsertError m)
return $ => BCKey
InsertEntrySet -> Rational
{ iesCurrency = curID -> Natural
, iesFromEntries = fs'' -> NonEmpty InsertEntry
, iesToEntries = ts'' -> 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 doEntries
:: (MonadInsertError m) :: (MonadInsertError m)
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-> CurrencyRId -> BCKey
-> T.Text
-> Rational -> Rational
-> Entry (AccountRId, AcntSign) () TagRId -> Entry (AccountRId, AcntSign) () TagRId
-> [Entry (AccountRId, AcntSign) v TagRId] -> [Entry (AccountRId, AcntSign) v TagRId]
-> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) -> StateT EntryBals m (NonEmpty InsertEntry)
doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
es' <- mapErrors f es es' <- mapErrors (balanceEntry f k) es
let e0val = tot - entrySum es' let e0val = tot - entrySum es'
-- TODO not dry -- TODO not dry
let s = fromIntegral $ sign2Int sign -- NOTE hack let s = fromIntegral $ sign2Int sign -- NOTE hack
modify (mapAdd_ (acntID, curID, budgetName) e0val) modify (mapAdd_ (acntID, k) e0val)
let e' = let e' =
InsertEntry InsertEntry
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID} { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
@ -976,13 +946,11 @@ liftInnerS = mapStateT (return . runIdentity)
balanceLinked balanceLinked
:: MonadInsertError m :: MonadInsertError m
=> Vector Rational => Vector Rational
-> CurrencyRId
-> T.Text
-> Natural -> Natural
-> AccountRId -> ABCKey
-> LinkDeferred Rational -> LinkDeferred Rational
-> StateT EntryBals m (Rational, Maybe DBDeferred) -> 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 (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
case res of 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 -- TODO this error would be much more informative if I had access to the
-- file from which it came -- file from which it came
Nothing -> throwError undefined Nothing -> throwError undefined
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID budgetName d (LinkDeferred d) -> liftInnerS $ balanceDeferred k d
where where
go s = negate . roundPrecision precision . (* s) . fromRational go s = negate . roundPrecision precision . (* s) . fromRational
balanceDeferred balanceDeferred
:: CurrencyRId :: ABCKey
-> AccountRId
-> T.Text
-> EntryValue Rational -> EntryValue Rational
-> State EntryBals (Rational, Maybe DBDeferred) -> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferred curID acntID budgetName (EntryValue t v) = do balanceDeferred k (EntryValue t v) = do
newval <- findBalance acntID curID budgetName t v newval <- findBalance k t v
let d = case t of let d = case t of
TFixed -> Nothing TFixed -> Nothing
TBalance -> Just $ EntryBalance v TBalance -> Just $ EntryBalance v
@ -1010,15 +976,14 @@ balanceDeferred curID acntID budgetName (EntryValue t v) = do
balanceEntry balanceEntry
:: (MonadInsertError m) :: (MonadInsertError m)
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-> CurrencyRId -> BCKey
-> T.Text
-> Entry (AccountRId, AcntSign) v TagRId -> Entry (AccountRId, AcntSign) v TagRId
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId) -> StateT EntryBals m InsertEntry
balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
let s = fromIntegral $ sign2Int sign let s = fromIntegral $ sign2Int sign
(newVal, deferred) <- f acntID eValue (newVal, deferred) <- f (acntID, k) eValue
modify (mapAdd_ (acntID, curID, budgetName) newVal) modify (mapAdd_ (acntID, k) newVal)
return $ return $
InsertEntry InsertEntry
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID} { 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} \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
findBalance findBalance
:: AccountRId :: ABCKey
-> CurrencyRId
-> T.Text
-> TransferType -> TransferType
-> Rational -> Rational
-> State EntryBals Rational -> State EntryBals Rational
findBalance acnt cur name t v = do findBalance k t v = do
curBal <- gets (M.findWithDefault 0 (acnt, cur, name)) curBal <- gets (M.findWithDefault 0 k)
return $ case t of return $ case t of
TBalance -> v - curBal TBalance -> v - curBal
TPercent -> v * curBal TPercent -> v * curBal
TFixed -> v TFixed -> v
--------------------------------------------------------------------------------
-- transfers
expandTransfers expandTransfers
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> CommitR => CommitR
@ -1122,3 +1088,9 @@ withDates
withDates bounds dp f = do withDates bounds dp f = do
days <- liftExcept $ expandDatePat bounds dp days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days 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, [])