From 1e5f40d7309b455cfbd3950f83672ce2d140d437 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 5 Feb 2023 18:45:56 -0500 Subject: [PATCH] ENH allow multiple budgets --- app/Main.hs | 2 +- dhall/Types.dhall | 3 +- dhall/common.dhall | 2 +- lib/Internal/Database/Ops.hs | 6 ++-- lib/Internal/Insert.hs | 62 +++++++++++++++++++++++------------- lib/Internal/Types.hs | 9 ++++-- 6 files changed, 54 insertions(+), 30 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 09c3fdf..b418112 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -163,7 +163,7 @@ runSync c = do Left es -> throwIO $ InsertException es Right s -> do flip runReaderT (s $ takeDirectory c) $ do - es1 <- insertBudget $ budget config + es1 <- concat <$> mapM insertBudget (budget config) es2 <- insertStatements config let es = es1 ++ es2 unless (null es) $ throwIO $ InsertException es diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 688278e..4bcada2 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -210,7 +210,8 @@ let Transfer = , transCurrency : CurID } -let Budget = { name : Text, income : List Income, transfers : List Transfer } +let Budget = + { budgetLabel : Text, income : List Income, transfers : List Transfer } in { CurID , AcntID diff --git a/dhall/common.dhall b/dhall/common.dhall index 9f966f1..79e02ca 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,7 +4,7 @@ let List/map = let T = ./Types.dhall - sha256:b29c40e8680e3bd2992180b1165a42f6cde1198cdc7efa4fd115e9e25eef50ea + sha256:27c65b31fe1b0dd58ff03ec0a37648f586914c81b81e5f33d3eac5a465475f2b let nullSplit = \(a : T.SplitAcnt) -> diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 6433f58..7bcddc4 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -102,14 +102,16 @@ nukeTables = do hashConfig :: Config -> [Int] hashConfig Config_ - { budget = Budget {transfers = xs, income = is} + { budget = bs , statements = ss } = - (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) + concatMap budgetHashes bs ++ (hash <$> ms) ++ (hash <$> ps) where (ms, ps) = partitionEithers $ fmap go ss go (StmtManual x) = Left x go (StmtImport x) = Right x + budgetHashes Budget {transfers = xs, income = is} = + (hash <$> xs) ++ (hash <$> is) setDiff :: Eq a => [a] -> [a] -> ([a], [a]) -- setDiff = setDiff' (==) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 2a36b47..f904ab2 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -103,9 +103,9 @@ withDates dp f = do -- budget insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] -insertBudget Budget {income = is, transfers = es} = do - es1 <- mapM insertIncome is - es2 <- mapM insertTransfer es +insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do + es1 <- mapM (insertIncome name) is + es2 <- mapM (insertTransfer name) es return $ concat $ es1 ++ es2 -- TODO this hashes twice (not that it really matters) @@ -131,6 +131,7 @@ data BudgetMeta = BudgetMeta { bmCommit :: !(Key CommitR) , bmWhen :: !Day , bmCur :: !CurID + , bmName :: !T.Text } data BudgetTx = BudgetTx @@ -138,15 +139,15 @@ data BudgetTx = BudgetTx , btFrom :: !(BudgetSplit IncomeBucket) , btTo :: !(BudgetSplit ExpenseBucket) , btValue :: !Rational - , btName :: !T.Text + , btDesc :: !T.Text } -insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError] -insertIncome i@Income {..} = +insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError] +insertIncome name i@Income {..} = whenHash CTIncome i [] $ \c -> unlessLeft (balanceIncome i) $ \balance -> do res <- withDates incWhen $ \day -> do - let meta = BudgetMeta c day incCurrency + 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 @@ -157,7 +158,7 @@ insertIncome i@Income {..} = , btFrom = BudgetSplit incFrom $ Just PostTax , btTo = BudgetSplit incToBal Nothing , btValue = balance - , btName = "balance after deductions" + , btDesc = "balance after deductions" } fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post) unlessLefts res $ return . concat @@ -175,7 +176,7 @@ fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts { btFrom = BudgetSplit from ib , btTo = BudgetSplit to $ Just alloBucket , btValue = dec2Rat v - , btName = desc + , btDesc = desc , btMeta = meta } @@ -185,7 +186,7 @@ fromTax meta from Tax {taxAcnt = to, taxValue = v} = { btFrom = BudgetSplit from (Just IntraTax) , btTo = BudgetSplit to (Just Fixed) , btValue = dec2Rat v - , btName = "" + , btDesc = "" , btMeta = meta } @@ -209,36 +210,51 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts sumTaxes :: [Tax] -> Rational sumTaxes = sum . fmap (dec2Rat . taxValue) -insertTransfer :: MonadUnliftIO m => Transfer -> MappingT m [InsertError] -insertTransfer t@Transfer {..} = +insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError] +insertTransfer name t@Transfer {..} = fmap concat $ whenHash CTExpense t [] $ \key -> do forM transAmounts $ \(TimeAmount amt pat) -> do res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key unlessLefts res $ return . concat where - meta d c = BudgetMeta {bmWhen = d, bmCur = transCurrency, bmCommit = c} + meta d c = + BudgetMeta + { bmWhen = d + , bmCur = transCurrency + , bmCommit = c + , bmName = name + } budgetTx (Amount desc v) d c = BudgetTx { btMeta = meta d c , btFrom = BudgetSplit transFrom Nothing , btTo = BudgetSplit transTo Nothing , btValue = dec2Rat v - , btName = desc + , btDesc = desc } 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) btName - skFrom <- insertSplit k sFrom - bFrom <- insert $ BudgetLabelR skFrom btName - forM_ (bsBucket btFrom) $ \b -> - insert_ $ IncomeBucketR bFrom b - skTo <- insertSplit k sTo - bTo <- insert $ BudgetLabelR skTo btName - forM_ (bsBucket btTo) $ \b -> - insert_ $ ExpenseBucketR bTo b + k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc + insertBudgetLabel name k IncomeBucketR sFrom btFrom + insertBudgetLabel name k ExpenseBucketR sTo btTo + where + name = bmName btMeta + +insertBudgetLabel + :: (MonadUnliftIO m, PersistRecordBackend record SqlBackend) + => T.Text + -> Key TransactionR + -> (Key BudgetLabelR -> a -> record) + -> KeySplit + -> BudgetSplit a + -> SqlPersistT m () +insertBudgetLabel name k bucketType split bs = do + sk <- insertSplit k split + bk <- insert $ BudgetLabelR sk name + forM_ (bsBucket bs) $ insert_ . bucketType bk splitPair :: MonadUnliftIO m diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 7e1c2a0..06f21b0 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -71,6 +71,7 @@ makeHaskellTypesWith data AccountTree = Placeholder T.Text T.Text [AccountTree] | Account T.Text T.Text + deriving (Eq, Generic, Hashable) TH.makeBaseFunctor ''AccountTree @@ -110,7 +111,7 @@ type CurID = T.Text data Config_ a = Config_ { global :: !Global - , budget :: !Budget + , budget :: ![Budget] , currencies :: ![Currency] , statements :: ![Statement] , accounts :: !a @@ -240,6 +241,10 @@ deriving instance Hashable DatePat -------------------------------------------------------------------------------- -- Budget (projecting into the future) +deriving instance Eq Budget + +deriving instance Hashable Budget + deriving instance Eq Income deriving instance Hashable Income @@ -312,7 +317,7 @@ deriving instance Hashable Transfer data Statement = StmtManual !Manual | StmtImport !Import - deriving (Generic, FromDhall) + deriving (Eq, Hashable, Generic, FromDhall) deriving instance Eq Manual