WIP balance all transactions in budget

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