REF don't use so many fields

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
+data BudgetTxType = BudgetTxType
-  { trxMeta :: !BudgetMeta
+  { bttType :: !AmountType
-  , trxFrom :: !(BudgetSplit IncomeBucket)
+  , bttTx :: !BudgetTx
-  , trxTo :: !(BudgetSplit ExpenseBucket)
-  , trxValue :: !Rational
-  , trxType :: AmountType
-  , trxDesc :: !T.Text
   }
 
-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
+                    BudgetTxType
-                      { trxMeta = meta
+                      { bttTx =
-                      , trxFrom = fromFun PostTax
+                          BudgetTx
-                      , trxTo = to
+                            { btMeta = meta
-                      , trxValue = balance
+                            , btWhen = day
-                      , trxType = FixedAmt
+                            , btFrom = fromFun PostTax
-                      , trxDesc = "balance after deductions"
+                            , 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])
+  -> m (EitherErr [BudgetTxType])
-fromAllo meta from Allocation {alloPath, alloAmts} = do
+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
+      BudgetTxType
-        { trxFrom = from
+        { bttTx =
-        , trxTo = to
+            BudgetTx
-        , trxValue = dec2Rat v
+              { btFrom = from
-        , trxDesc = desc
+              , btWhen = day
-        , trxType = FixedAmt
+              , btTo = to
-        , trxMeta = meta
+              , 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)
+  -> m (EitherErr BudgetTxType)
-fromTax meta from Tax {taxAcnt = to, taxValue = v} =
+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
+    BudgetTxType
-      { trxFrom = from
+      { bttTx =
-      , trxTo = BudgetSplit to_ (Just Fixed)
+          BudgetTx
-      , trxValue = dec2Rat v
+            { btFrom = from
-      , trxDesc = ""
+            , btWhen = day
-      , trxType = FixedAmt
+            , btTo = BudgetSplit to_ (Just Fixed)
-      , trxMeta = meta
+            , 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]
+expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
-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 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
+                  BudgetTxType
-                    { trxMeta = meta
+                    { bttTx =
-                    , trxFrom = BudgetSplit transFrom Nothing
+                        BudgetTx
-                    , trxTo = to
+                          { btMeta = meta
-                    , trxValue = dec2Rat v
+                          , btWhen = day
-                    , trxType = atype
+                          , btFrom = BudgetSplit transFrom Nothing
-                    , trxDesc = desc
+                          , 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