From 7f2a87670cb689c6daac1acac7d848be56e6cc3a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 12 Feb 2023 16:52:42 -0500 Subject: [PATCH] WIP balance all transactions in budget --- lib/Internal/Insert.hs | 153 +++++++++++++++++++---------------------- 1 file changed, 70 insertions(+), 83 deletions(-) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index ee1f72d..597ebd6 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -107,22 +107,12 @@ withDates dp f = do insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do - es1 <- mapM (insertIncome name) is - es2 <- insertTransfers name es - return $ concat es1 ++ es2 - --- 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 + res1 <- mapM (insertIncome name) is + res2 <- expandTransfers name es + unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ + \txs -> do + let bals = balanceTransfers txs + concat <$> mapM insertBudgetTx bals -- TODO allow currency conversions here data BudgetSplit b = BudgetSplit @@ -145,55 +135,67 @@ data BudgetTx = BudgetTx , 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 name i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = - whenHash CTIncome i [] $ \c -> - unlessLeft (balanceIncome i) $ \balance -> do - res <- withDates incWhen $ \day -> do + whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of + Left e -> return $ Left [e] + Right balance -> + fmap (fmap concat) $ withDates incWhen $ \day -> do let meta = BudgetMeta c day incCurrency name let fromAllos b = concatMap (fromAllo meta incFrom (Just b)) let pre = fromAllos PreTax incPretax let tax = fmap (fromTax meta incFrom) incTaxes let post = fromAllos PostTax incPosttax let bal = - BudgetTx - { btMeta = meta - , btFrom = BudgetSplit incFrom $ Just PostTax - , btTo = BudgetSplit incToBal Nothing - , btValue = balance - , btDesc = "balance after deductions" + TransferTx + { trxMeta = meta + , trxFrom = BudgetSplit incFrom $ Just PostTax + , trxTo = BudgetSplit incToBal Nothing + , trxValue = balance + , trxType = FixedAmt + , trxDesc = "balance after deductions" } - fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post) - unlessLefts res $ return . concat + return $ bal : (pre ++ tax ++ post) fromAllo :: BudgetMeta -> AcntID -> Maybe IncomeBucket -> Allocation - -> [BudgetTx] + -> [TransferTx] fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} = fmap (toBT alloPath) alloAmts where toBT to (Amount desc v) = - BudgetTx - { btFrom = BudgetSplit from ib - , btTo = BudgetSplit to $ Just alloBucket - , btValue = dec2Rat v - , btDesc = desc - , btMeta = meta + TransferTx + { trxFrom = BudgetSplit from ib + , trxTo = BudgetSplit to $ Just alloBucket + , trxValue = dec2Rat v + , trxDesc = desc + , trxType = FixedAmt + , trxMeta = meta } -fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx +fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx fromTax meta from Tax {taxAcnt = to, taxValue = v} = - BudgetTx - { btFrom = BudgetSplit from (Just IntraTax) - , btTo = BudgetSplit to (Just Fixed) - , btValue = dec2Rat v - , btDesc = "" - , btMeta = meta + TransferTx + { trxFrom = BudgetSplit from (Just IntraTax) + , trxTo = BudgetSplit to (Just Fixed) + , trxValue = dec2Rat v + , trxDesc = "" + , trxType = FixedAmt + , trxMeta = meta } balanceIncome :: Income -> EitherErr Rational @@ -216,12 +218,6 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts sumTaxes :: [Tax] -> Rational 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 name ts = do txs <- mapM (expandTransfer name) ts @@ -231,21 +227,27 @@ expandTransfers name ts = do balanceTransfers :: [TransferTx] -> [BudgetTx] balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts 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)) lookupBal = M.findWithDefault (error "this should not happen") 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 t = BudgetTx { btMeta = trxMeta - , btFrom = BudgetSplit trxFrom Nothing - , btTo = BudgetSplit trxTo Nothing + , btFrom = trxFrom + , btTo = trxTo , btValue = x , 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 -- probably work, but for credit accounts I might need to supply a negative -- target value @@ -268,42 +270,14 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} in return $ TransferTx { trxMeta = meta - , trxFrom = transFrom - , trxTo = transTo + , trxFrom = BudgetSplit transFrom Nothing + , trxTo = BudgetSplit transTo Nothing , trxValue = dec2Rat v , trxType = atype , trxDesc = desc } 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 BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do 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 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