From 047e9edbb90a6f091608cab38100975ef3fcc3b0 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 12 Feb 2023 22:18:31 -0500 Subject: [PATCH] REF don't use so many fields --- lib/Internal/Insert.hs | 223 +++++++++++++++++++++++------------------ 1 file changed, 124 insertions(+), 99 deletions(-) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index e777a3c..9b33b8f 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -128,6 +128,30 @@ insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do let bals = balanceTransfers txs concat <$> mapM insertBudgetTx bals +balanceTransfers :: [BudgetTxType] -> [BudgetTx] +balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts + where + initBals = + M.fromList $ + fmap (,0) $ + L.nub $ + (fmap (bsAcnt . btTo . bttTx) ts ++ fmap (bsAcnt . btTo . bttTx) ts) + updateBal x = M.update (Just . (+ x)) + lookupBal = M.findWithDefault (error "this should not happen") + go bals btt = + let tx = bttTx btt + from = bsAcnt $ btFrom tx + to = bsAcnt $ btTo tx + bal = lookupBal to bals + x = amtToMove bal (bttType btt) (btValue tx) + in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x}) + -- 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 + amtToMove _ FixedAmt x = x + amtToMove bal Percent x = -(x / 100 * bal) + amtToMove bal Target x = x - bal + -- TODO allow currency conversions here data BudgetSplit b = BudgetSplit { bsAcnt :: !AcntID @@ -136,33 +160,30 @@ data BudgetSplit b = BudgetSplit data BudgetMeta = BudgetMeta { bmCommit :: !(Key CommitR) - , bmWhen :: !Day , bmCur :: !CurID , bmName :: !T.Text } data BudgetTx = BudgetTx { btMeta :: !BudgetMeta + , btWhen :: !Day , btFrom :: !(BudgetSplit IncomeBucket) , btTo :: !(BudgetSplit ExpenseBucket) , btValue :: !Rational , btDesc :: !T.Text } -data TransferTx = TransferTx - { trxMeta :: !BudgetMeta - , trxFrom :: !(BudgetSplit IncomeBucket) - , trxTo :: !(BudgetSplit ExpenseBucket) - , trxValue :: !Rational - , trxType :: AmountType - , trxDesc :: !T.Text +data BudgetTxType = BudgetTxType + { bttType :: !AmountType + , bttTx :: !BudgetTx } -insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [TransferTx]) +insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType]) insertIncome name i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = whenHash CTIncome i (Right []) $ \c -> do + let meta = BudgetMeta c incCurrency name let balRes = balanceIncome i fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just) toRes <- lift $ expandTarget incToBal @@ -171,78 +192,76 @@ insertIncome Right (balance, fromFun, to) -> fmap (fmap (concat . concat)) $ withDates incWhen $ \day -> do - let meta = BudgetMeta c day incCurrency name let fromAllos b = fmap (fmap concat . concatEitherL) - . mapM (lift . fromAllo meta (fromFun b)) + . mapM (lift . fromAllo day meta (fromFun b)) pre <- fromAllos PreTax incPretax tax <- concatEitherL - <$> mapM (lift . fromTax meta (fromFun IntraTax)) incTaxes + <$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes post <- fromAllos PostTax incPosttax let bal = - TransferTx - { trxMeta = meta - , trxFrom = fromFun PostTax - , trxTo = to - , trxValue = balance - , trxType = FixedAmt - , trxDesc = "balance after deductions" + BudgetTxType + { bttTx = + BudgetTx + { btMeta = meta + , btWhen = day + , btFrom = fromFun PostTax + , btTo = to + , btValue = balance + , btDesc = "balance after deductions" + } + , bttType = FixedAmt } return $ concatEithersL [Right [bal], tax, pre, post] fromAllo :: MonadFinance m - => BudgetMeta + => Day + -> BudgetMeta -> BudgetSplit IncomeBucket -> Allocation - -> m (EitherErr [TransferTx]) -fromAllo meta from Allocation {alloPath, alloAmts} = do + -> m (EitherErr [BudgetTxType]) +fromAllo day meta from Allocation {alloPath, alloAmts} = do -- TODO this is going to be repeated a zillion times (might matter) res <- expandTarget alloPath return $ (\to -> fmap (toBT to) alloAmts) <$> res where toBT to (Amount desc v) = - TransferTx - { trxFrom = from - , trxTo = to - , trxValue = dec2Rat v - , trxDesc = desc - , trxType = FixedAmt - , trxMeta = meta + BudgetTxType + { bttTx = + BudgetTx + { btFrom = from + , btWhen = day + , btTo = to + , btValue = dec2Rat v + , btDesc = desc + , btMeta = meta + } + , bttType = FixedAmt } -expandTarget :: MonadFinance m => TransferTarget -> m (EitherErr (BudgetSplit ExpenseBucket)) -expandTarget t = case t of - ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b)) - GenericTarget i -> checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $ (`BudgetSplit` Nothing) - -checkAcntType :: MonadFinance m => AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a) -checkAcntType t = checkAcntTypes (t :| []) - -checkAcntTypes :: MonadFinance m => NE.NonEmpty AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a) -checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i - where - go t - | t `L.elem` ts = Right $ f i - | otherwise = Left $ AccountError i t - fromTax :: MonadFinance m - => BudgetMeta + => Day + -> BudgetMeta -> BudgetSplit IncomeBucket -> Tax - -> m (EitherErr TransferTx) -fromTax meta from Tax {taxAcnt = to, taxValue = v} = + -> m (EitherErr BudgetTxType) +fromTax day meta from Tax {taxAcnt = to, taxValue = v} = -- TODO this is going to be repeated a zillion times (might matter) checkAcntType ExpenseT to $ \to_ -> - TransferTx - { trxFrom = from - , trxTo = BudgetSplit to_ (Just Fixed) - , trxValue = dec2Rat v - , trxDesc = "" - , trxType = FixedAmt - , trxMeta = meta + BudgetTxType + { bttTx = + BudgetTx + { btFrom = from + , btWhen = day + , btTo = BudgetSplit to_ (Just Fixed) + , btValue = dec2Rat v + , btDesc = "" + , btMeta = meta + } + , bttType = FixedAmt } balanceIncome :: Income -> EitherErr Rational @@ -265,43 +284,16 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts sumTaxes :: [Tax] -> Rational sumTaxes = sum . fmap (dec2Rat . taxValue) -expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx]) +expandTransfers + :: MonadFinance m + => T.Text + -> [Transfer] + -> SqlPersistT m (EitherErrs [BudgetTxType]) expandTransfers name ts = do txs <- mapM (expandTransfer name) ts - return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs + return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs -balanceTransfers :: [TransferTx] -> [BudgetTx] -balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts - where - 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 from = bsAcnt trxFrom - to = bsAcnt trxTo - bal = lookupBal to bals - x = amtToMove bal trxType trxValue - t = - BudgetTx - { btMeta = trxMeta - , btFrom = trxFrom - , btTo = trxTo - , btValue = x - , btDesc = trxDesc - } - 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 - amtToMove _ FixedAmt x = x - amtToMove bal Percent x = -(x / 100 * bal) - amtToMove bal Target x = x - bal - -expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx]) +expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType]) expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} = whenHash CTExpense t (Right []) $ \key -> fmap (fmap concat . concatEithersL) $ @@ -313,27 +305,30 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} Right to -> withDates pat $ \day -> let meta = BudgetMeta - { bmWhen = day - , bmCur = transCurrency + { bmCur = transCurrency , bmCommit = key , bmName = name } tx = - TransferTx - { trxMeta = meta - , trxFrom = BudgetSplit transFrom Nothing - , trxTo = to - , trxValue = dec2Rat v - , trxType = atype - , trxDesc = desc + BudgetTxType + { bttTx = + BudgetTx + { btMeta = meta + , btWhen = day + , btFrom = BudgetSplit transFrom Nothing + , btTo = to + , btValue = dec2Rat v + , btDesc = desc + } + , bttType = atype } in return $ Right tx insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] -insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do +insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue unlessLefts_ res $ \(sFrom, sTo) -> do - k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc + k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc insertBudgetLabel name k IncomeBucketR sFrom btFrom insertBudgetLabel name k ExpenseBucketR sTo btTo where @@ -373,6 +368,36 @@ splitPair from to cur val = do , sCurrency = cur } +expandTarget + :: MonadFinance m + => TransferTarget + -> m (EitherErr (BudgetSplit ExpenseBucket)) +expandTarget t = case t of + ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b)) + GenericTarget i -> + checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $ + (`BudgetSplit` Nothing) + +checkAcntType + :: MonadFinance m + => AcntType + -> AcntID + -> (AcntID -> a) + -> m (EitherErr a) +checkAcntType t = checkAcntTypes (t :| []) + +checkAcntTypes + :: MonadFinance m + => NE.NonEmpty AcntType + -> AcntID + -> (AcntID -> a) + -> m (EitherErr a) +checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i + where + go t + | t `L.elem` ts = Right $ f i + | otherwise = Left $ AccountError i t + -------------------------------------------------------------------------------- -- statements