WIP balance all transactions in budget

This commit is contained in:
Nathan Dwarshuis 2023-02-12 16:52:42 -05:00
parent e6a39cb5ea
commit 7f2a87670c
1 changed files with 70 additions and 83 deletions

View File

@ -107,22 +107,12 @@ withDates dp f = do
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
es1 <- mapM (insertIncome name) is res1 <- mapM (insertIncome name) is
es2 <- insertTransfers name es res2 <- expandTransfers name es
return $ concat es1 ++ es2 unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
\txs -> do
-- TODO this hashes twice (not that it really matters) let bals = balanceTransfers txs
whenHash concat <$> mapM insertBudgetTx bals
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> b
-> (Key CommitR -> SqlPersistT m b)
-> SqlPersistT m b
whenHash t o def f = do
let h = hash o
hs <- lift $ askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
-- TODO allow currency conversions here -- TODO allow currency conversions here
data BudgetSplit b = BudgetSplit data BudgetSplit b = BudgetSplit
@ -145,55 +135,67 @@ data BudgetTx = BudgetTx
, btDesc :: !T.Text , btDesc :: !T.Text
} }
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError] data TransferTx = TransferTx
{ trxMeta :: !BudgetMeta
, trxFrom :: !(BudgetSplit IncomeBucket)
, trxTo :: !(BudgetSplit ExpenseBucket)
, trxValue :: !Rational
, trxType :: AmountType
, trxDesc :: !T.Text
}
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [TransferTx])
insertIncome insertIncome
name name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
whenHash CTIncome i [] $ \c -> whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of
unlessLeft (balanceIncome i) $ \balance -> do Left e -> return $ Left [e]
res <- withDates incWhen $ \day -> do Right balance ->
fmap (fmap concat) $ withDates incWhen $ \day -> do
let meta = BudgetMeta c day incCurrency name let meta = BudgetMeta c day incCurrency name
let fromAllos b = concatMap (fromAllo meta incFrom (Just b)) let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
let pre = fromAllos PreTax incPretax let pre = fromAllos PreTax incPretax
let tax = fmap (fromTax meta incFrom) incTaxes let tax = fmap (fromTax meta incFrom) incTaxes
let post = fromAllos PostTax incPosttax let post = fromAllos PostTax incPosttax
let bal = let bal =
BudgetTx TransferTx
{ btMeta = meta { trxMeta = meta
, btFrom = BudgetSplit incFrom $ Just PostTax , trxFrom = BudgetSplit incFrom $ Just PostTax
, btTo = BudgetSplit incToBal Nothing , trxTo = BudgetSplit incToBal Nothing
, btValue = balance , trxValue = balance
, btDesc = "balance after deductions" , trxType = FixedAmt
, trxDesc = "balance after deductions"
} }
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post) return $ bal : (pre ++ tax ++ post)
unlessLefts res $ return . concat
fromAllo fromAllo
:: BudgetMeta :: BudgetMeta
-> AcntID -> AcntID
-> Maybe IncomeBucket -> Maybe IncomeBucket
-> Allocation -> Allocation
-> [BudgetTx] -> [TransferTx]
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} = fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
fmap (toBT alloPath) alloAmts fmap (toBT alloPath) alloAmts
where where
toBT to (Amount desc v) = toBT to (Amount desc v) =
BudgetTx TransferTx
{ btFrom = BudgetSplit from ib { trxFrom = BudgetSplit from ib
, btTo = BudgetSplit to $ Just alloBucket , trxTo = BudgetSplit to $ Just alloBucket
, btValue = dec2Rat v , trxValue = dec2Rat v
, btDesc = desc , trxDesc = desc
, btMeta = meta , trxType = FixedAmt
, trxMeta = meta
} }
fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx
fromTax meta from Tax {taxAcnt = to, taxValue = v} = fromTax meta from Tax {taxAcnt = to, taxValue = v} =
BudgetTx TransferTx
{ btFrom = BudgetSplit from (Just IntraTax) { trxFrom = BudgetSplit from (Just IntraTax)
, btTo = BudgetSplit to (Just Fixed) , trxTo = BudgetSplit to (Just Fixed)
, btValue = dec2Rat v , trxValue = dec2Rat v
, btDesc = "" , trxDesc = ""
, btMeta = meta , trxType = FixedAmt
, trxMeta = meta
} }
balanceIncome :: Income -> EitherErr Rational balanceIncome :: Income -> EitherErr Rational
@ -216,12 +218,6 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
sumTaxes :: [Tax] -> Rational sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue) sumTaxes = sum . fmap (dec2Rat . taxValue)
insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
insertTransfers name ts = do
res <- expandTransfers name ts
unlessLefts res $ \txs ->
fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx]) expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
expandTransfers name ts = do expandTransfers name ts = do
txs <- mapM (expandTransfer name) ts txs <- mapM (expandTransfer name) ts
@ -231,21 +227,27 @@ expandTransfers name ts = do
balanceTransfers :: [TransferTx] -> [BudgetTx] balanceTransfers :: [TransferTx] -> [BudgetTx]
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
where where
initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts) initBals =
M.fromList $
fmap (,0) $
L.nub $
(fmap (bsAcnt . trxTo) ts ++ fmap (bsAcnt . trxTo) ts)
updateBal x = M.update (Just . (+ x)) updateBal x = M.update (Just . (+ x))
lookupBal = M.findWithDefault (error "this should not happen") lookupBal = M.findWithDefault (error "this should not happen")
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} = go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
let bal = lookupBal trxTo bals let from = bsAcnt trxFrom
to = bsAcnt trxTo
bal = lookupBal to bals
x = amtToMove bal trxType trxValue x = amtToMove bal trxType trxValue
t = t =
BudgetTx BudgetTx
{ btMeta = trxMeta { btMeta = trxMeta
, btFrom = BudgetSplit trxFrom Nothing , btFrom = trxFrom
, btTo = BudgetSplit trxTo Nothing , btTo = trxTo
, btValue = x , btValue = x
, btDesc = trxDesc , btDesc = trxDesc
} }
in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t) in (updateBal x to $ updateBal (-x) from bals, t)
-- TODO might need to query signs to make this intuitive; as it is this will -- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative -- probably work, but for credit accounts I might need to supply a negative
-- target value -- target value
@ -268,42 +270,14 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
in return $ in return $
TransferTx TransferTx
{ trxMeta = meta { trxMeta = meta
, trxFrom = transFrom , trxFrom = BudgetSplit transFrom Nothing
, trxTo = transTo , trxTo = BudgetSplit transTo Nothing
, trxValue = dec2Rat v , trxValue = dec2Rat v
, trxType = atype , trxType = atype
, trxDesc = desc , trxDesc = desc
} }
return $ concat <$> concatEithersL res return $ concat <$> concatEithersL res
data TransferTx = TransferTx
{ trxMeta :: !BudgetMeta
, trxFrom :: !AcntID
, trxTo :: !AcntID
, trxValue :: !Rational
, trxType :: AmountType
, trxDesc :: !T.Text
}
-- amountBalance
-- :: (MonadFinance m, MonadBalance m)
-- => AmountType
-- -> AcntID
-- -> Rational
-- -> SqlPersistT m (EitherErr Rational)
-- amountBalance at i v = do
-- res <- lookupAccountKey i
-- case res of
-- Left e -> return $ Left e
-- Right k -> do
-- b <- lookupBalance k
-- return $ Right $ case at of
-- FixedAmt -> v
-- -- TODO what is the sign for this?
-- Percent -> v / 100 * b
-- -- TODO what is the sign for this?
-- Target -> b - v
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
@ -457,3 +431,16 @@ lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR)) lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency) lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
-- TODO this hashes twice (not that it really matters)
whenHash
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> b
-> (Key CommitR -> SqlPersistT m b)
-> SqlPersistT m b
whenHash t o def f = do
let h = hash o
hs <- lift $ askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def