ENH use stratified buckets for budget tagging

dhall/Types.dhall

@@ -174,45 +174,44 @@ let Import =
 
 let Statement = < StmtManual : Manual | StmtImport : Import >
 
-let Bucket = < Fixed | Investment | Savings | Guiltless >
+let ExpenseBucket = < Fixed | Investment | Savings | Guiltless >
 
-let Amount = \(v : Type) -> { amtValue : v, amtDesc : Text }
+let IncomeBucket = < PreTax | IntraTax | PostTax >
 
-let TimeAmount = { taWhen : DatePat, taAmt : Amount Decimal }
+let Amount = { amtValue : Decimal, amtDesc : Text }
+
+let TimeAmount = { taWhen : DatePat, taAmt : Amount }
 
 let Tax = { taxAcnt : AcntID, taxValue : Decimal }
 
 let Allocation =
-      \(v : Type) ->
       { alloPath : AcntID
-        , alloBucket : Bucket
+      , alloBucket : ExpenseBucket
-        , alloAmts : List (Amount v)
+      , alloAmts : List Amount
       , alloCurrency : CurID
       }
 
-let PreAllocation = Allocation Decimal
-
-let PostAllocation = Allocation (Optional Decimal)
-
 let Income =
       { incGross : Decimal
       , incCurrency : CurID
       , incWhen : DatePat
-      , incAccount : AcntID
+      , incFrom : AcntID
-      , incPretax : List PreAllocation
+      , incPretax : List Allocation
       , incTaxes : List Tax
-      , incPosttax : List PostAllocation
+      , incPosttax : List Allocation
+      , incToBal : AcntID
       }
 
 let Expense =
       { expFrom : AcntID
       , expTo : AcntID
-      , expBucket : Bucket
+      , expBucket : ExpenseBucket
       , expAmounts : List TimeAmount
       , expCurrency : CurID
       }
 
-let Budget = { income : List Income, expenses : List Expense }
+let Budget =
+      { income : List Income, expenses : List Expense, manual : List Manual }
 
 in  { CurID
     , AcntID
@@ -251,12 +250,11 @@ in  { CurID
     , Statement
     , Expense
     , Income
-    , Bucket
+    , IncomeBucket
+    , ExpenseBucket
     , Budget
     , Tax
     , Allocation
-    , PreAllocation
-    , PostAllocation
     , Amount
     , TimeAmount
     }

dhall/common.dhall

@@ -4,7 +4,7 @@ let List/map =
 
 let T =
       ./Types.dhall
-        sha256:dfbc39a5fe5f4b78b86dc5d4def8de689ff800b6ee506c7a63d573c0be02e976
+        sha256:91a8e19048591cc6b7f72dc62f0d5d7d569864f4736b5649422c746904d03a52
 
 let nullSplit =
       \(a : T.SplitAcnt) ->

lib/Internal/Database/Model.hs

@@ -51,7 +51,6 @@ TransactionR sql=transactions
     commit CommitRId OnDeleteCascade
     date Day
     description T.Text
-    bucket T.Text Maybe
     deriving Show Eq
 SplitR sql=splits
     transaction TransactionRId OnDeleteCascade
@@ -60,6 +59,15 @@ SplitR sql=splits
     memo T.Text
     value Rational
     deriving Show Eq
+BudgetLabelR
+    split SplitRId
+    name T.Text
+ExpenseBucketR
+    budgetLabel BudgetLabelRId
+    bucket T.Text
+IncomeBucketR
+    budgetLabel BudgetLabelRId
+    bucket T.Text
 |]
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign)

lib/Internal/Insert.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Insert
@@ -90,6 +90,8 @@ insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
 insertBudget Budget {income = is, expenses = es} = do
   es1 <- mapM insertIncome is
   es2 <- mapM insertExpense es
+  -- es3 <- mapM insertBudgetManual ms
+  -- return $ concat $ es1 ++ es2 ++ es3
   return $ concat $ es1 ++ es2
 
 -- TODO this hashes twice (not that it really matters)
@@ -105,27 +107,86 @@ whenHash t o def f = do
   hs <- asks kmNewCommits
   if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
 
-insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
+-- TODO allow currency conversions here
-insertIncome
+data BudgetSplit b = BudgetSplit
-  i@Income
+  { bsAcnt :: AcntID
-    { incCurrency = cur
+  , bsBucket :: Maybe b
-    , incWhen = dp
+  }
-    , incAccount = from
-    , incTaxes = taxes
-    } =
-    whenHash CTIncome i [] $ \c ->
-      unlessLeft (balanceIncome i) $ \balanced -> do
-        bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-        fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
-          -- TODO why are these separate?
-          nontaxRes <- alloTxs concat (allocationToTx from day) balanced
-          taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes
-          unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs ->
-            lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs
-    where
-      alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx
 
-balanceIncome :: Income -> EitherErr [BalAllocation]
+data BudgetMeta = BudgetMeta
+  { bmCommit :: Key CommitR
+  , bmWhen :: Day
+  , bmCur :: CurID
+  }
+
+data BudgetTx = BudgetTx
+  { btMeta :: BudgetMeta
+  , btFrom :: BudgetSplit IncomeBucket
+  , btTo :: BudgetSplit ExpenseBucket
+  , btValue :: Rational
+  , btDesc :: T.Text
+  }
+
+insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
+insertIncome i@Income {..} =
+  whenHash CTIncome i [] $ \c ->
+    unlessLeft (balanceIncome i) $ \balance ->
+      fmap concat $ withDates incWhen $ \day -> do
+        let meta = BudgetMeta c day incCurrency
+        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"
+                }
+        fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
+
+fromAllo
+  :: BudgetMeta
+  -> AcntID
+  -> Maybe IncomeBucket
+  -> Allocation
+  -> [BudgetTx]
+fromAllo meta from ib Allocation {..} = 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
+        }
+
+fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx
+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
+    }
+
+withDates
+  :: MonadUnliftIO m
+  => DatePat
+  -> (Day -> MappingT m a)
+  -> MappingT m [a]
+withDates dp f = do
+  bounds <- askBounds
+  mapM f (expandDatePat bounds dp)
+
+askBounds :: MonadUnliftIO m => MappingT m Bounds
+askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval
+
+balanceIncome :: Income -> EitherErr Rational
 balanceIncome
   Income
     { incGross = g
@@ -133,122 +194,33 @@ balanceIncome
     , incPretax = pre
     , incTaxes = tax
     , incPosttax = post
-    } = (preRat ++) <$> balancePostTax dp bal postRat
+    }
+    | bal < 0 = Left $ AllocationError undefined dp
+    | otherwise = Right bal
     where
-      preRat = mapAlloAmts dec2Rat <$> pre
+      bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax
-      postRat = mapAlloAmts (fmap dec2Rat) <$> post
-      bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)
 
-mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b
+sumAllocation :: Allocation -> Rational
-mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as}
+sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
-
-sumAllocations :: [BalAllocation] -> Rational
-sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
 
 sumTaxes :: [Tax] -> Rational
 sumTaxes = sum . fmap (dec2Rat . taxValue)
 
-balancePostTax :: DatePat -> Rational -> [RawAllocation] -> EitherErr [BalAllocation]
-balancePostTax dp bal as
-  | null as = err NoAllocations
-  | otherwise = case partitionEithers $ fmap hasVal as of
-      ([([empty], nonmissing)], bs) ->
-        let s = bal - sumAllocations (nonmissing : bs)
-         in if s < 0
-              then err ExceededTotal
-              else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
-      ([], _) -> err MissingBlank
-      _ -> err TooManyBlanks
-  where
-    hasVal a@Allocation {alloAmts = xs} =
-      case partitionEithers $ fmap maybeAmt xs of
-        ([], bs) -> Right a {alloAmts = bs}
-        (unbal, bs) -> Left (unbal, a {alloAmts = bs})
-    maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
-    maybeAmt a = Left a
-    err t = Left $ AllocationError t dp
-
--- TODO lens reinvention
-mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
-mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
-
-allocationToTx
-  :: MonadUnliftIO m
-  => AcntID
-  -> Day
-  -> BalAllocation
-  -> MappingT m (EitherErrs [(KeyTx, Bucket)])
-allocationToTx
-  from
-  day
-  Allocation
-    { alloPath = to
-    , alloBucket = b
-    , alloCurrency = cur
-    , alloAmts = as
-    } =
-    second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
-
-taxToTx
-  :: MonadUnliftIO m
-  => AcntID
-  -> Day
-  -> T.Text
-  -> Tax
-  -> MappingT m (EitherErrs KeyTx)
-taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
-  txPair day from to cur (dec2Rat v) ""
-
-transferToTx
-  :: MonadUnliftIO m
-  => Day
-  -> AcntID
-  -> AcntID
-  -> T.Text
-  -> BalAmount
-  -> MappingT m (EitherErrs KeyTx)
-transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
-  txPair day from to cur v d
-
 insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
-insertExpense
+insertExpense e@Expense {..} =
-  e@Expense
+  fmap (concat . concat) $ whenHash CTExpense e [] $ \key -> do
-    { expFrom = from
+    forM expAmounts $ \(TimeAmount amt pat) ->
-    , expTo = to
+      withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
-    , expCurrency = cur
-    , expBucket = buc
-    , expAmounts = as
-    } = do
-    whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
   where
-      go key amt = do
+    meta d c = BudgetMeta {bmWhen = d, bmCur = expCurrency, bmCommit = c}
-        res <- timeAmountToTx from to cur amt
+    budgetTx (Amount desc v) d c =
-        unlessLefts_ res $
+      BudgetTx
-          lift . mapM_ (insertTxBucket (Just buc) key)
+        { btMeta = meta d c
-
+        , btFrom = BudgetSplit expFrom Nothing
-timeAmountToTx
+        , btTo = BudgetSplit expTo Nothing
-  :: MonadUnliftIO m
+        , btValue = dec2Rat v
-  => AcntID
+        , btDesc = desc
-  -> AcntID
-  -> CurID
-  -> TimeAmount
-  -> MappingT m (EitherErrs [KeyTx])
-timeAmountToTx
-  from
-  to
-  cur
-  TimeAmount
-    { taWhen = dp
-    , taAmt =
-      Amount
-        { amtValue = v
-        , amtDesc = d
         }
-    } = do
-    bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-    concatEithersL <$> mapM tx (expandDatePat bounds dp)
-    where
-      tx day = txPair day from to cur (dec2Rat v) d
 
 --------------------------------------------------------------------------------
 -- statements
@@ -302,7 +274,7 @@ txPair
   => Day
   -> AcntID
   -> AcntID
-  -> T.Text
+  -> CurID
   -> Rational
   -> T.Text
   -> MappingT m (EitherErrs KeyTx)
@@ -317,6 +289,35 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
+splitPair
+  :: MonadUnliftIO m
+  => AcntID
+  -> AcntID
+  -> CurID
+  -> Rational
+  -> MappingT m (EitherErrs (KeySplit, KeySplit))
+splitPair from to cur val = do
+  s1 <- split from (-val)
+  s2 <- split to val
+  return $ concatEithers2 s1 s2 (,)
+  where
+    split a v =
+      resolveSplit $
+        Split
+          { sAcnt = a
+          , sValue = v
+          , sComment = ""
+          , sCurrency = cur
+          }
+
+-- tx =
+--   Tx
+--     { txDescr = desc
+--     , txDate = day
+--     , txTags = []
+--     , txSplits = [split from (-val), split to val]
+--     }
+
 resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
 resolveTx t@Tx {txSplits = ss} = do
   res <- concatEithersL <$> mapM resolveSplit ss
@@ -339,17 +340,55 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
 -- return $ case (aid, cid, sign) of
 --   _ -> Nothing
 
-insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
+-- insertTax
-insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
+--   :: MonadUnliftIO m
-  k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
+--   => AcntID
+--   -> CurID
+--   -> Day
+--   -> Key CommitR
+--   -> Tax
+--   -> MappingT m [InsertError]
+-- insertTax from cur day commit Tax {taxAcnt = to, taxValue = amnt} =
+--   insertBudgetValue IntraTax Fixed from to cur commit day "" $ dec2Rat amnt
+
+-- insertAllocation
+--   :: MonadUnliftIO m
+--   => AcntID
+--   -> CurID
+--   -> IncomeBucket
+--   -> Day
+--   -> Key CommitR
+--   -> Allocation Decimal
+--   -> MappingT m [InsertError]
+-- insertAllocation from cur ib d c (Allocation to xb as _) = concat <$> mapM go as
+--   where
+--     go (Amount v desc) = insertBudgetValue ib xb from to cur c d desc $ dec2Rat v
+
+insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
+insertBudgetTx BudgetTx {..} = do
+  res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
+  unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
+    k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
+    skFrom <- insertSplit k sFrom
+    bFrom <- insert $ BudgetLabelR skFrom ""
+    forM_ (bsBucket btFrom) $ \b ->
+      insert_ $ IncomeBucketR bFrom $ showT b
+    skTo <- insertSplit k sTo
+    bTo <- insert $ BudgetLabelR skTo ""
+    forM_ (bsBucket btTo) $ \b ->
+      insert_ $ ExpenseBucketR bTo $ showT b
+
+insertTxBucket :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
+insertTxBucket c Tx {txDate = d, txDescr = e, txSplits = ss} = do
+  k <- insert $ TransactionR c d e
   mapM_ (insertSplit k) ss
 
 insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
-insertTx = insertTxBucket Nothing
+insertTx = insertTxBucket
 
-insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
+insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
 insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
-  insert_ $ SplitR t cid aid c v
+  insert $ SplitR t cid aid c v
 
 lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
 lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount

lib/Internal/Types.hs

@@ -24,12 +24,11 @@ import Dhall.TH
 import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
--- import RIO.State
 import qualified RIO.Text as T
 import RIO.Time
 
 -------------------------------------------------------------------------------
--- YAML CONFIG
+-- DHALL CONFIG
 -------------------------------------------------------------------------------
 
 makeHaskellTypesWith
@@ -43,7 +42,8 @@ makeHaskellTypesWith
   , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
   , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
   , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
-  , MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
+  , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
+  , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@@ -57,6 +57,12 @@ makeHaskellTypesWith
   , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
   , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
   , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
+  , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
+  , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
+  , SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
+  , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
+  , SingleConstructor "Expense" "Expense" "(./dhall/Types.dhall).Expense"
+  , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
   ]
 
 -------------------------------------------------------------------------------
@@ -216,61 +222,41 @@ deriving instance Hashable DatePat
 --------------------------------------------------------------------------------
 -- Budget (projecting into the future)
 
-data Income = Income
+deriving instance Eq Income
-  { incGross :: !Decimal
-  , incCurrency :: !CurID
-  , incWhen :: !DatePat
-  , incAccount :: !AcntID
-  , incPretax :: ![Allocation Decimal]
-  , incTaxes :: ![Tax]
-  , incPosttax :: ![Allocation (Maybe Decimal)]
-  }
-  deriving (Eq, Hashable, Generic, FromDhall)
 
-data Budget = Budget
+deriving instance Hashable Income
-  { income :: ![Income]
-  , expenses :: ![Expense]
-  }
-  deriving (Generic, FromDhall)
 
 deriving instance Eq Tax
 
 deriving instance Hashable Tax
 
-data Amount v = Amount
+deriving instance Eq Amount
-  { amtValue :: !v
-  , amtDesc :: !T.Text
-  }
-  deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
 
-data Allocation v = Allocation
+deriving instance Hashable Amount
-  { alloPath :: !AcntID
-  , alloBucket :: !Bucket
-  , alloAmts :: ![Amount v]
-  , alloCurrency :: !CurID
-  }
-  deriving (Eq, Hashable, Generic, FromDhall)
 
-deriving instance Eq Bucket
+deriving instance Eq Allocation
 
-deriving instance Hashable Bucket
+deriving instance Hashable Allocation
 
-deriving instance Show Bucket
+deriving instance Eq IncomeBucket
 
-data TimeAmount = TimeAmount
+deriving instance Hashable IncomeBucket
-  { taWhen :: !DatePat
-  , taAmt :: Amount Decimal
-  }
-  deriving (Eq, Hashable, Generic, FromDhall)
 
-data Expense = Expense
+deriving instance Show IncomeBucket
-  { expFrom :: !AcntID
+
-  , expTo :: !AcntID
+deriving instance Eq ExpenseBucket
-  , expBucket :: !Bucket
+
-  , expAmounts :: ![TimeAmount]
+deriving instance Hashable ExpenseBucket
-  , expCurrency :: !CurID
+
-  }
+deriving instance Show ExpenseBucket
-  deriving (Eq, Hashable, Generic, FromDhall)
+
+deriving instance Eq TimeAmount
+
+deriving instance Hashable TimeAmount
+
+deriving instance Eq Expense
+
+deriving instance Hashable Expense
 
 --------------------------------------------------------------------------------
 -- Statements (data from the past)
@@ -502,14 +488,6 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawAmount = Amount (Maybe Rational)
-
-type BalAmount = Amount Rational
-
-type RawAllocation = Allocation (Maybe Rational)
-
-type BalAllocation = Allocation Rational
-
 type RawSplit = Split AcntID (Maybe Rational) CurID
 
 type BalSplit = Split AcntID Rational CurID