FIX don't hash budget components (since they are interdependent)

2023-03-01 20:38:11 -05:00 · 2023-03-01 20:38:11 -05:00 · d89b63e59a
parent 6e2598b274
commit d89b63e59a
4 changed files with 80 additions and 78 deletions
--- 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' (==)
--- 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
--- 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
--- 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"]