ENH allow multiple budgets

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

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

dhall/common.dhall

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

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' (==)

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
+insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
-  es1 <- mapM insertIncome is
+  es1 <- mapM (insertIncome name) is
-  es2 <- mapM insertTransfer es
+  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 :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
-insertIncome i@Income {..} =
+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 :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError]
-insertTransfer t@Transfer {..} =
+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
+    k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
-    skFrom <- insertSplit k sFrom
+    insertBudgetLabel name k IncomeBucketR sFrom btFrom
-    bFrom <- insert $ BudgetLabelR skFrom btName
+    insertBudgetLabel name k ExpenseBucketR sTo btTo
-    forM_ (bsBucket btFrom) $ \b ->
+  where
-      insert_ $ IncomeBucketR bFrom b
+    name = bmName btMeta
-    skTo <- insertSplit k sTo
+
-    bTo <- insert $ BudgetLabelR skTo btName
+insertBudgetLabel
-    forM_ (bsBucket btTo) $ \b ->
+  :: (MonadUnliftIO m, PersistRecordBackend record SqlBackend)
-      insert_ $ ExpenseBucketR bTo b
+  => 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

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