WIP assign buckets more sanely

dhall/Types.dhall

@@ -193,9 +193,18 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
 
 let Tax = { taxAcnt : AcntID, taxValue : Decimal }
 
+let TransferTarget =
+      < ExpenseTarget :
+          { _1xtarget :
+              {- this is the only place expense accounts may be specified -}
+              AcntID
+          , _2xtarget : ExpenseBucket
+          }
+      | GenericTarget : AcntID
+      >
+
 let Allocation =
-      { alloPath : AcntID
+      { alloPath : TransferTarget
-      , alloBucket : ExpenseBucket
       , alloAmts : List Amount
       , alloCurrency : CurID
       }
@@ -204,17 +213,19 @@ let Income =
       { incGross : Decimal
       , incCurrency : CurID
       , incWhen : DatePat
-      , incFrom : AcntID
+      , incFrom :
+          {- this must be an income AcntID, and is the only place income
+          accounts may be specified in the entire budget -}
+          AcntID
       , incPretax : List Allocation
       , incTaxes : List Tax
       , incPosttax : List Allocation
-      , incToBal : AcntID
+      , incToBal : TransferTarget
       }
 
 let Transfer =
       { transFrom : AcntID
-      , transTo : AcntID
+      , transTo : TransferTarget
-      , transBucket : ExpenseBucket
       , transAmounts : List TimeAmount
       , transCurrency : CurID
       }
@@ -267,4 +278,5 @@ in  { CurID
     , Amount
     , TimeAmount
     , AmountType
+    , TransferTarget
     }

lib/Internal/Database/Model.hs

@@ -59,7 +59,7 @@ IncomeBucketR sql=income_buckets
     deriving Show Eq
 |]
 
-type AccountMap = M.Map AcntID (AccountRId, AcntSign)
+type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
 type CurrencyMap = M.Map CurID CurrencyRId
 

lib/Internal/Database/Ops.hs

@@ -212,7 +212,7 @@ tree2Entity t parents name des =
 tree2Records
   :: AcntType
   -> AccountTree
-  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
+  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
@@ -227,7 +227,7 @@ tree2Records t = go []
           k = entityKey e
        in ( [acnt k n (fmap snd ps) d]
           , expand k $ fmap fst ps
-          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))]
+          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
           )
     toPath = T.intercalate "/" . (atName t :) . reverse
     acnt k n ps = Entity k . AccountR n (toPath ps)

lib/Internal/Insert.hs

@@ -7,6 +7,7 @@ where
 import Data.Hashable
 import Database.Persist.Class
 import Database.Persist.Sql hiding (Single, Statement)
+import GHC.Utils.Misc hiding (split)
 import Internal.Database.Model
 import Internal.Statement
 import Internal.Types hiding (sign)
@@ -14,6 +15,7 @@ import Internal.Utils
 import RIO hiding (to)
 import qualified RIO.List as L
 import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
@@ -95,12 +97,13 @@ dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 withDates
   :: MonadFinance m
   => DatePat
-  -> (Day -> SqlPersistT m a)
+  -> (Day -> SqlPersistT m (EitherErrs a))
   -> SqlPersistT m (EitherErrs [a])
 withDates dp f = do
   bounds <- lift $ askDBState kmBudgetInterval
-  let days = expandDatePat bounds dp
+  case expandDatePat bounds dp of
-  mapM (mapM f) days
+    Left es -> return $ Left es
+    Right days -> concatEithersL <$> mapM f days
 
 --------------------------------------------------------------------------------
 -- budget
@@ -159,55 +162,88 @@ insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs
 insertIncome
   name
   i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
-    whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of
+    whenHash CTIncome i (Right []) $ \c -> do
-      Left e -> return $ Left [e]
+      let balRes = balanceIncome i
-      Right balance ->
+      fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
-        fmap (fmap concat) $ withDates incWhen $ \day -> do
+      toRes <- lift $ expandTarget incToBal
-          let meta = BudgetMeta c day incCurrency name
+      case concatEither3 balRes fromRes toRes (,,) of
-          let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
+        Left es -> return $ Left es
-          let pre = fromAllos PreTax incPretax
+        Right (balance, fromFun, to) ->
-          let tax = fmap (fromTax meta incFrom) incTaxes
+          fmap (fmap (concat . concat)) $
-          let post = fromAllos PostTax incPosttax
+            withDates incWhen $ \day -> do
-          let bal =
+              let meta = BudgetMeta c day incCurrency name
-                TransferTx
+              let fromAllos b =
-                  { trxMeta = meta
+                    fmap (fmap concat . concatEitherL)
-                  , trxFrom = BudgetSplit incFrom $ Just PostTax
+                      . mapM (lift . fromAllo meta (fromFun b))
-                  , trxTo = BudgetSplit incToBal Nothing
+              pre <- fromAllos PreTax incPretax
-                  , trxValue = balance
+              tax <-
-                  , trxType = FixedAmt
+                concatEitherL
-                  , trxDesc = "balance after deductions"
+                  <$> mapM (lift . fromTax meta (fromFun IntraTax)) incTaxes
-                  }
+              post <- fromAllos PostTax incPosttax
-          return $ bal : (pre ++ tax ++ post)
+              let bal =
+                    TransferTx
+                      { trxMeta = meta
+                      , trxFrom = fromFun PostTax
+                      , trxTo = to
+                      , trxValue = balance
+                      , trxType = FixedAmt
+                      , trxDesc = "balance after deductions"
+                      }
+              return $ concatEithersL [Right [bal], tax, pre, post]
 
 fromAllo
-  :: BudgetMeta
+  :: MonadFinance m
-  -> AcntID
+  => BudgetMeta
-  -> Maybe IncomeBucket
+  -> BudgetSplit IncomeBucket
   -> Allocation
-  -> [TransferTx]
+  -> m (EitherErr [TransferTx])
-fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
+fromAllo meta from Allocation {alloPath, alloAmts} = do
-  fmap (toBT alloPath) alloAmts
+  -- 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 = BudgetSplit from ib
+        { trxFrom = from
-        , trxTo = BudgetSplit to $ Just alloBucket
+        , trxTo = to
         , trxValue = dec2Rat v
         , trxDesc = desc
         , trxType = FixedAmt
         , trxMeta = meta
         }
 
-fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx
+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
+  -> BudgetSplit IncomeBucket
+  -> Tax
+  -> m (EitherErr TransferTx)
 fromTax meta from Tax {taxAcnt = to, taxValue = v} =
-  TransferTx
+  -- TODO this is going to be repeated a zillion times (might matter)
-    { trxFrom = BudgetSplit from (Just IntraTax)
+  checkAcntType ExpenseT to $ \to_ ->
-    , trxTo = BudgetSplit to (Just Fixed)
+    TransferTx
-    , trxValue = dec2Rat v
+      { trxFrom = from
-    , trxDesc = ""
+      , trxTo = BudgetSplit to_ (Just Fixed)
-    , trxType = FixedAmt
+      , trxValue = dec2Rat v
-    , trxMeta = meta
+      , trxDesc = ""
-    }
+      , trxType = FixedAmt
+      , trxMeta = meta
+      }
 
 balanceIncome :: Income -> EitherErr Rational
 balanceIncome
@@ -234,7 +270,6 @@ expandTransfers name ts = do
   txs <- mapM (expandTransfer name) ts
   return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
 
--- TODO the entire budget needs to have this process applied to it
 balanceTransfers :: [TransferTx] -> [BudgetTx]
 balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
   where
@@ -268,30 +303,35 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta
 
 expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
 expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
-  whenHash CTExpense t (Right []) $ \key -> do
+  whenHash CTExpense t (Right []) $ \key ->
-    res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
+    fmap (fmap concat . concatEithersL) $
-      withDates pat $ \day ->
+      forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
-        let meta =
+        -- TODO this is going to be repeated a zillion times (might matter)
-              BudgetMeta
+        res <- lift $ expandTarget transTo
-                { bmWhen = day
+        case res of
-                , bmCur = transCurrency
+          Left e -> return $ Left [e]
-                , bmCommit = key
+          Right to -> withDates pat $ \day ->
-                , bmName = name
+            let meta =
-                }
+                  BudgetMeta
-         in return $
+                    { bmWhen = day
-              TransferTx
+                    , bmCur = transCurrency
-                { trxMeta = meta
+                    , bmCommit = key
-                , trxFrom = BudgetSplit transFrom Nothing
+                    , bmName = name
-                , trxTo = BudgetSplit transTo Nothing
+                    }
-                , trxValue = dec2Rat v
+                tx =
-                , trxType = atype
+                  TransferTx
-                , trxDesc = desc
+                    { trxMeta = meta
-                }
+                    , trxFrom = BudgetSplit transFrom Nothing
-    return $ concat <$> concatEithersL res
+                    , trxTo = to
+                    , trxValue = dec2Rat v
+                    , trxType = atype
+                    , trxDesc = desc
+                    }
+             in return $ Right tx
 
 insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
 insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
-  res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
+  res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
   unlessLefts_ res $ \(sFrom, sTo) -> do
     k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
     insertBudgetLabel name k IncomeBucketR sFrom btFrom
@@ -318,7 +358,7 @@ splitPair
   -> AcntID
   -> CurID
   -> Rational
-  -> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
+  -> m (EitherErrs (KeySplit, KeySplit))
 splitPair from to cur val = do
   s1 <- split from (-val)
   s2 <- split to val
@@ -358,7 +398,7 @@ insertManual
       -- let days = expandDatePat bounds dp
       let dayRes = expandDatePat bounds dp
       unlessLefts dayRes $ \days -> do
-        txRes <- mapM tx days
+        txRes <- mapM (lift . tx) days
         unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
     where
       tx day = txPair day from to u (dec2Rat v) e
@@ -369,7 +409,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
   -- transactions will be desired
   recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
     bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
-    res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
+    res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
     unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
   where
     recoverIO x rest = do
@@ -391,7 +431,7 @@ txPair
   -> CurID
   -> Rational
   -> T.Text
-  -> SqlPersistT m (EitherErrs KeyTx)
+  -> m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
     split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@@ -403,12 +443,12 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
-resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
+resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
 resolveTx t@Tx {txSplits = ss} = do
   res <- concatEithersL <$> mapM resolveSplit ss
   return $ fmap (\kss -> t {txSplits = kss}) res
 
-resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
+resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
 resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
   aid <- lookupAccountKey p
   cid <- lookupCurrency c
@@ -431,17 +471,20 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
 insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
   insert $ SplitR t cid aid c v
 
-lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
+lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
-lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
+lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
 
-lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
+lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
-lookupAccountKey = fmap (fmap fst) . lookupAccount
+lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
 
-lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
+lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
-lookupAccountSign = fmap (fmap snd) . lookupAccount
+lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
 
-lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
+lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
-lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
+lookupAccountType = fmap (fmap thdOf3) . lookupAccount
+
+lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
+lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
 
 -- TODO this hashes twice (not that it really matters)
 whenHash

lib/Internal/Types.hs

@@ -34,6 +34,7 @@ makeHaskellTypesWith
   , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
   , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
   , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
+  , MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@@ -50,8 +51,8 @@ makeHaskellTypesWith
   , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
   , SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
   , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-  , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
   , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
+  , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
   ]
 
 -------------------------------------------------------------------------------
@@ -300,6 +301,10 @@ deriving instance Eq TimeAmount
 
 deriving instance Hashable TimeAmount
 
+deriving instance Eq TransferTarget
+
+deriving instance Hashable TransferTarget
+
 deriving instance Eq Transfer
 
 deriving instance Hashable Transfer
@@ -582,6 +587,7 @@ data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
 data InsertError
   = RegexError !T.Text
   | MatchValPrecisionError !Natural !Natural
+  | AccountError !AcntID !AcntType
   | InsertIOError !T.Text
   | ParseError !T.Text
   | ConversionError !T.Text

lib/Internal/Utils.hs

@@ -9,10 +9,13 @@ module Internal.Utils
   , leftToMaybe
   , dec2Rat
   , concatEithers2
+  , concatEithers3
   , concatEither3
   , concatEither2
   , concatEitherL
   , concatEithersL
+  , concatEither2M
+  , concatEithers2M
   , parseRational
   , showError
   , unlessLeft_
@@ -23,7 +26,8 @@ module Internal.Utils
   , showT
   , lookupErr
   , gregorians
-  , uncurry3
+  -- , uncurry3
+
   , xGregToDay
   , plural
   , compileMatch
@@ -313,6 +317,8 @@ showError other = (: []) $ case other of
     where
       showGreg (Just g) = showGregorian_ g
       showGreg Nothing = "Inf"
+  -- TODO define
+  (AccountError _ _) -> undefined
   (PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat]
     where
       pat =
@@ -478,6 +484,11 @@ concatEither2 a b fun = case (a, b) of
   (Right a_, Right b_) -> Right $ fun a_ b_
   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
 
+concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
+concatEither2M a b fun = case (a, b) of
+  (Right a_, Right b_) -> Right <$> fun a_ b_
+  _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
+
 concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
 concatEither3 a b c fun = case (a, b, c) of
   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
@@ -486,13 +497,21 @@ concatEither3 a b c fun = case (a, b, c) of
 concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
 concatEithers2 a b = merge . concatEither2 a b
 
--- concatEithers3
+concatEithers2M
---   :: Either [x] a
+  :: Monad m
---   -> Either [x] b
+  => Either [x] a
---   -> Either [x] c
+  -> Either [x] b
---   -> (a -> b -> c -> d)
+  -> (a -> b -> m c)
---   -> Either [x] d
+  -> m (Either [x] c)
--- concatEithers3 a b c = merge . concatEither3 a b c
+concatEithers2M a b = fmap merge . concatEither2M a b
+
+concatEithers3
+  :: Either [x] a
+  -> Either [x] b
+  -> Either [x] c
+  -> (a -> b -> c -> d)
+  -> Either [x] d
+concatEithers3 a b c = merge . concatEither3 a b c
 
 concatEitherL :: [Either x a] -> Either [x] [a]
 concatEitherL as = case partitionEithers as of