From 36c6a56f1bce8638df0f8157963c8ef471369cf2 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 30 Jan 2023 20:13:25 -0500 Subject: [PATCH] ENH use stratified buckets for budget tagging --- dhall/Types.dhall | 40 ++--- dhall/common.dhall | 2 +- lib/Internal/Database/Model.hs | 10 +- lib/Internal/Insert.hs | 311 +++++++++++++++++++-------------- lib/Internal/Types.hs | 86 ++++----- 5 files changed, 236 insertions(+), 213 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 6a66c42..a4a8f03 100644 --- a/dhall/Types.dhall +++ b/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 - , alloAmts : List (Amount v) - , alloCurrency : CurID - } - -let PreAllocation = Allocation Decimal - -let PostAllocation = Allocation (Optional Decimal) + { alloPath : AcntID + , alloBucket : ExpenseBucket + , alloAmts : List Amount + , alloCurrency : CurID + } let Income = { incGross : Decimal , incCurrency : CurID , incWhen : DatePat - , incAccount : AcntID - , incPretax : List PreAllocation + , incFrom : AcntID + , 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 } diff --git a/dhall/common.dhall b/dhall/common.dhall index fe4d589..206a113 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,7 +4,7 @@ let List/map = let T = ./Types.dhall - sha256:dfbc39a5fe5f4b78b86dc5d4def8de689ff800b6ee506c7a63d573c0be02e976 + sha256:91a8e19048591cc6b7f72dc62f0d5d7d569864f4736b5649422c746904d03a52 let nullSplit = \(a : T.SplitAcnt) -> diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index 873cbf7..e88f8f0 100644 --- a/lib/Internal/Database/Model.hs +++ b/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) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 8453590..e21c6b7 100644 --- a/lib/Internal/Insert.hs +++ b/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] -insertIncome - i@Income - { incCurrency = cur - , 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 +-- TODO allow currency conversions here +data BudgetSplit b = BudgetSplit + { bsAcnt :: AcntID + , bsBucket :: Maybe b + } -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 - postRat = mapAlloAmts (fmap dec2Rat) <$> post - bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) + bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax -mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b -mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as} - -sumAllocations :: [BalAllocation] -> Rational -sumAllocations = sum . concatMap (fmap amtValue . alloAmts) +sumAllocation :: Allocation -> Rational +sumAllocation = sum . fmap (dec2Rat . 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 - e@Expense - { expFrom = from - , expTo = to - , expCurrency = cur - , expBucket = buc - , expAmounts = as - } = do - whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as - where - go key amt = do - res <- timeAmountToTx from to cur amt - unlessLefts_ res $ - lift . mapM_ (insertTxBucket (Just buc) key) - -timeAmountToTx - :: MonadUnliftIO m - => AcntID - -> AcntID - -> CurID - -> TimeAmount - -> MappingT m (EitherErrs [KeyTx]) -timeAmountToTx - from - to - cur - TimeAmount - { taWhen = dp - , taAmt = - Amount - { amtValue = v - , amtDesc = d +insertExpense e@Expense {..} = + fmap (concat . concat) $ whenHash CTExpense e [] $ \key -> do + forM expAmounts $ \(TimeAmount amt pat) -> + withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key + where + meta d c = BudgetMeta {bmWhen = d, bmCur = expCurrency, bmCommit = c} + budgetTx (Amount desc v) d c = + BudgetTx + { btMeta = meta d c + , btFrom = BudgetSplit expFrom Nothing + , btTo = BudgetSplit expTo Nothing + , btValue = dec2Rat v + , btDesc = desc } - } = 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 () -insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do - k <- insert $ TransactionR c d e (fmap (T.pack . show) b) +-- insertTax +-- :: MonadUnliftIO m +-- => 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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 226d219..4e32063 100644 --- a/lib/Internal/Types.hs +++ b/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 - { incGross :: !Decimal - , incCurrency :: !CurID - , incWhen :: !DatePat - , incAccount :: !AcntID - , incPretax :: ![Allocation Decimal] - , incTaxes :: ![Tax] - , incPosttax :: ![Allocation (Maybe Decimal)] - } - deriving (Eq, Hashable, Generic, FromDhall) +deriving instance Eq Income -data Budget = Budget - { income :: ![Income] - , expenses :: ![Expense] - } - deriving (Generic, FromDhall) +deriving instance Hashable Income deriving instance Eq Tax deriving instance Hashable Tax -data Amount v = Amount - { amtValue :: !v - , amtDesc :: !T.Text - } - deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) +deriving instance Eq Amount -data Allocation v = Allocation - { alloPath :: !AcntID - , alloBucket :: !Bucket - , alloAmts :: ![Amount v] - , alloCurrency :: !CurID - } - deriving (Eq, Hashable, Generic, FromDhall) +deriving instance Hashable Amount -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 - { taWhen :: !DatePat - , taAmt :: Amount Decimal - } - deriving (Eq, Hashable, Generic, FromDhall) +deriving instance Hashable IncomeBucket -data Expense = Expense - { expFrom :: !AcntID - , expTo :: !AcntID - , expBucket :: !Bucket - , expAmounts :: ![TimeAmount] - , expCurrency :: !CurID - } - deriving (Eq, Hashable, Generic, FromDhall) +deriving instance Show IncomeBucket + +deriving instance Eq ExpenseBucket + +deriving instance Hashable ExpenseBucket + +deriving instance Show ExpenseBucket + +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