From d89b63e59a56f4fd589f0179a85d74353080c2e7 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 1 Mar 2023 20:38:11 -0500 Subject: [PATCH] FIX don't hash budget components (since they are interdependent) --- lib/Internal/Database/Ops.hs | 5 +- lib/Internal/Insert.hs | 149 ++++++++++++++++++----------------- lib/Internal/Types.hs | 2 +- lib/Internal/Utils.hs | 2 +- 4 files changed, 80 insertions(+), 78 deletions(-) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index aeae945..54aeac0 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -95,14 +95,11 @@ hashConfig Config_ { budget = bs , statements = ss - } = - concatMap budgetHashes bs ++ (hash <$> ms) ++ (hash <$> ps) + } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) where (ms, ps) = partitionEithers $ fmap go ss go (StmtManual x) = Left x go (StmtImport x) = Right x - budgetHashes Budget {transfers = xs, income = is} = - (hash <$> xs) ++ (hash <$> is) setDiff :: Eq a => [a] -> [a] -> ([a], [a]) -- setDiff = setDiff' (==) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index d90004e..b744088 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -119,14 +119,15 @@ withDates dp f = do -- 5. insert all transactions insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] -insertBudget Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss} = do - res1 <- mapM (insertIncome name) is - res2 <- expandTransfers name es - unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ - \txs -> do - unlessLefts (addShadowTransfers ss txs) $ \shadow -> do - let bals = balanceTransfers $ txs ++ shadow - concat <$> mapM insertBudgetTx bals +insertBudget b@(Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss}) = + whenHash CTBudget b [] $ \key -> do + res1 <- mapM (insertIncome key name) is + res2 <- expandTransfers key name es + unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ + \txs -> do + unlessLefts (addShadowTransfers ss txs) $ \shadow -> do + let bals = balanceTransfers $ txs ++ shadow + concat <$> mapM insertBudgetTx bals -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType] @@ -173,13 +174,15 @@ shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do (if asInclude then id else not) $ x `elem` asList balanceTransfers :: [BudgetTxType] -> [BudgetTx] -balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts +balanceTransfers ts = + snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts where initBals = M.fromList $ fmap (,0) $ L.nub $ - (fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts) + fmap (btTo . bttTx) ts + ++ fmap (btFrom . bttTx) ts updateBal x = M.update (Just . (+ x)) lookupBal = M.findWithDefault (error "this should not happen") go bals btt = @@ -197,7 +200,7 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) amtToMove bal Target x = x - bal data BudgetMeta = BudgetMeta - { bmCommit :: !(Key CommitR) + { bmCommit :: !CommitRId , bmCur :: !BudgetCurrency , bmName :: !T.Text } @@ -216,40 +219,41 @@ data BudgetTxType = BudgetTxType , bttTx :: !BudgetTx } -insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType]) +insertIncome :: MonadFinance m => CommitRId -> T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType]) insertIncome + key name - i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = - whenHash CTIncome i (Right []) $ \c -> do - let meta = BudgetMeta c (NoX incCurrency) name - let balRes = balanceIncome i - fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom - case concatEither2 balRes fromRes (,) of - Left es -> return $ Left es - -- TODO this hole seems sloppy... - Right (balance, _) -> - fmap (fmap (concat . concat)) $ - withDates incWhen $ \day -> do - let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom) - pre <- fromAllos incPretax - tax <- - concatEitherL - <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes - post <- fromAllos incPosttax - let bal = - BudgetTxType - { bttTx = - BudgetTx - { btMeta = meta - , btWhen = day - , btFrom = incFrom - , btTo = incToBal - , btValue = balance - , btDesc = "balance after deductions" - } - , bttType = FixedAmt - } - return $ concatEithersL [Right [bal], tax, Right pre, Right post] + i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do + -- whenHash CTIncome i (Right []) $ \c -> do + let meta = BudgetMeta key (NoX incCurrency) name + let balRes = balanceIncome i + fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom + case concatEither2 balRes fromRes (,) of + Left es -> return $ Left es + -- TODO this hole seems sloppy... + Right (balance, _) -> + fmap (fmap (concat . concat)) $ + withDates incWhen $ \day -> do + let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom) + pre <- fromAllos incPretax + tax <- + concatEitherL + <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes + post <- fromAllos incPosttax + let bal = + BudgetTxType + { bttTx = + BudgetTx + { btMeta = meta + , btWhen = day + , btFrom = incFrom + , btTo = incToBal + , btValue = balance + , btDesc = "balance after deductions" + } + , bttType = FixedAmt + } + return $ concatEithersL [Right [bal], tax, Right pre, Right post] fromAllo :: MonadFinance m @@ -325,39 +329,40 @@ sumTaxes = sum . fmap (dec2Rat . taxValue) expandTransfers :: MonadFinance m - => T.Text + => CommitRId + -> T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [BudgetTxType]) -expandTransfers name ts = do - txs <- mapM (expandTransfer name) ts +expandTransfers key name ts = do + txs <- mapM (expandTransfer key name) ts return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs -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) $ - forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do - withDates pat $ \day -> - let meta = - BudgetMeta - { bmCur = transCurrency - , bmCommit = key - , bmName = name - } - tx = - BudgetTxType - { bttTx = - BudgetTx - { btMeta = meta - , btWhen = day - , btFrom = transFrom - , btTo = transTo - , btValue = dec2Rat v - , btDesc = desc - } - , bttType = atype - } - in return $ Right tx +expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType]) +expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = + -- whenHash CTExpense t (Right []) $ \key -> + fmap (fmap concat . concatEithersL) $ + forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do + withDates pat $ \day -> + let meta = + BudgetMeta + { bmCur = transCurrency + , bmCommit = key + , bmName = name + } + tx = + BudgetTxType + { bttTx = + BudgetTx + { btMeta = meta + , btWhen = day + , btFrom = transFrom + , btTo = transTo + , 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, btWhen} = do diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 5ed8a70..99b7393 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -524,7 +524,7 @@ data ConfigHashes = ConfigHashes , chImport :: ![Int] } -data ConfigType = CTIncome | CTExpense | CTShadow | CTManual | CTImport +data ConfigType = CTBudget | CTManual | CTImport deriving (Eq, Show, Read, Enum) instance PersistFieldSql ConfigType where diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 4435471..d259cae 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -350,7 +350,7 @@ showError other = (: []) $ case other of (MatchValPrecisionError d p) -> T.unwords ["Match denominator", showT d, "must be less than", showT p] (LookupError t f) -> - T.unwords ["Could not find field", singleQuote f, "when resolving", what] + T.unwords ["Could not find field", f, "when resolving", what] where what = case t of SplitIDField st -> T.unwords ["split", idName st, "ID"]