FIX separate running totals by budget label

lib/Internal/Budget.hs

@@ -15,7 +15,7 @@ import RIO.Time
 readBudget
   :: (MonadInsertError m, MonadFinance m)
   => Budget
-  -> m (Either CommitR [Tx TxCommit])
+  -> m (Either CommitR [Tx CommitR])
 readBudget
   b@Budget
     { bgtLabel
@@ -33,9 +33,8 @@ readBudget
         Nothing -> return []
         Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let tc = BudgetCommit key bgtLabel
+          let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
-          let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
-          let res2 = expandTransfers tc budgetSpan bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
@@ -79,13 +78,15 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- loop into a fold which I don't feel like doing now :(
 readIncome
   :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
+  => CommitR
+  -> T.Text
   -> IntAllocations
   -> DaySpan
   -> Income
-  -> m [Tx TxCommit]
+  -> m [Tx CommitR]
 readIncome
-  tc
+  key
+  name
   (intPre, intTax, intPost)
   ds
   Income
@@ -145,18 +146,19 @@ readIncome
             (fromRational balance)
             ()
         -- TODO make this into one large tx?
-        allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
+        allos <- mapErrors (allo2Trans key name day incFrom) (pre ++ tax ++ post)
         let bal =
               Tx
-                { txCommit = tc
+                { txCommit = key
                 , txDate = day
                 , txPrimary = Left primary
                 , txOther = []
                 , txDescr = "balance after deductions"
+                , txBudget = name
                 }
         -- TODO use real name here
         if balance < 0
-          then throwError $ InsertException [IncomeError day "" balance]
+          then throwError $ InsertException [IncomeError day name balance]
           else return (bal : allos)
 
 periodScaler
@@ -259,12 +261,13 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
 
 allo2Trans
   :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
+  => CommitR
+  -> T.Text
   -> Day
   -> TaggedAcnt
   -> FlatAllocation Rational
-  -> m (Tx TxCommit)
+  -> m (Tx CommitR)
-allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
+allo2Trans meta name day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
   -- TODO double here?
   p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
   return
@@ -274,6 +277,7 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
       , txPrimary = Left p
       , txOther = []
       , txDescr = faDesc
+      , txBudget = name
       }
 
 allocatePre
@@ -351,8 +355,8 @@ allocatePost precision aftertax = fmap (fmap go)
 addShadowTransfers
   :: (MonadInsertError m, MonadFinance m)
   => [ShadowTransfer]
-  -> [Tx TxCommit]
+  -> [Tx CommitR]
-  -> m [Tx TxCommit]
+  -> m [Tx CommitR]
 addShadowTransfers ms = mapErrors go
   where
     go tx = do
@@ -361,7 +365,7 @@ addShadowTransfers ms = mapErrors go
 
 fromShadow
   :: (MonadInsertError m, MonadFinance m)
-  => Tx TxCommit
+  => Tx CommitR
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
@@ -369,7 +373,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
   es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
   return $ if not res then Nothing else Just es
 
-shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
+shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
   -- NOTE this will only match against the primary entry set since those
   -- are what are guaranteed to exist from a transfer

lib/Internal/Database.hs

@@ -459,16 +459,17 @@ readUpdates hashes = do
         (
           ( entrysets ^. EntrySetRId
           , txs ^. TransactionRDate
+          , txs ^. TransactionRBudgetName
           , entrysets ^. EntrySetRCurrency
           )
         , entries
         )
       )
   let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
-  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
+  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate)
   return (makeRE . snd <$> toRead, toUpdate')
   where
-    makeUES ((_, day, curID), es) = do
+    makeUES ((_, day, name, curID), es) = do
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -493,6 +494,7 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = tot
+                  , utBudget = E.unValue name
                   }
             Right x ->
               Right $
@@ -506,15 +508,17 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = ()
+                  , utBudget = E.unValue name
                   }
         _ -> throwError undefined
-    makeRE ((_, day, curID), entry) =
+    makeRE ((_, day, name, curID), entry) =
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
             , reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
             , reValue = entryRValue e
+            , reBudget = E.unValue name
             }
 
 splitFrom
@@ -641,15 +645,16 @@ insertAll ebs = do
   mapM_ updateTx toUpdate
   forM_ (groupWith itxCommit toInsert) $
     \(c, ts) -> do
-      ck <- insert $ getCommit c
+      ck <- insert c
       mapM_ (insertTx ck) ts
-  where
+
-    getCommit (HistoryCommit c) = c
+-- where
-    getCommit (BudgetCommit c _) = c
+--   getCommit (HistoryCommit c) = c
+--   getCommit (BudgetCommit c _) = c
 
 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
-  k <- insert $ TransactionR c itxDate itxDescr
+  k <- insert $ TransactionR c itxDate itxDescr itxBudget
   mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
@@ -658,11 +663,11 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
       let rebalance = any (isJust . ieDeferred) (fs ++ ts)
       esk <- insert $ EntrySetR tk iesCurrency i rebalance
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
-    go k i e = do
+    go k i e = void $ insertEntry k i e
-      ek <- insertEntry k i e
+
-      case itxCommit of
+-- case itxCommit of
-        BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
+--   BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
-        _ -> return ()
+--   _ -> return ()
 
 insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
 insertEntry

lib/Internal/History.hs

@@ -38,10 +38,10 @@ splitHistory = partitionEithers . fmap go
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => PairedTransfer
-  -> m (Either CommitR [Tx TxCommit])
+  -> m (Either CommitR [Tx CommitR])
 readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
   bounds <- askDBState kmStatementInterval
-  expandTransfer (HistoryCommit c) bounds ht
+  expandTransfer c historyName bounds ht
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -50,11 +50,11 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [Tx TxCommit])
+  -> m (Either CommitR [Tx CommitR])
 readHistStmt root i = eitherHash CTImport i return $ \c -> do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
-  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
+  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@@ -306,6 +306,7 @@ toTx
                 , esTo = t
                 }
         , txOther = fmap Left ss
+        , txBudget = historyName
         }
     where
       curRes = do
@@ -502,3 +503,6 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
       w <- readT "whole number" x
       k <- readSign sign
       return (k, w)
+
+historyName :: T.Text
+historyName = "history"

lib/Internal/Types/Database.hs

@@ -44,6 +44,7 @@ TransactionR sql=transactions
     commit CommitRId OnDeleteCascade
     date Day
     description T.Text
+    budgetName T.Text
     deriving Show Eq
 EntrySetR sql=entry_sets
     transaction TransactionRId OnDeleteCascade
@@ -65,10 +66,6 @@ TagRelationR sql=tag_relations
     entry EntryRId OnDeleteCascade
     tag TagRId OnDeleteCascade
     deriving Show Eq
-BudgetLabelR sql=budget_labels
-    entry EntryRId OnDeleteCascade
-    budgetName T.Text
-    deriving Show Eq
 |]
 
 data ConfigType = CTBudget | CTManual | CTImport

lib/Internal/Types/Main.hs

@@ -75,6 +75,7 @@ data ReadEntry = ReadEntry
   , reAcnt :: !AccountRId
   , reValue :: !Rational
   , reDate :: !Day
+  , reBudget :: !T.Text
   }
   deriving (Show)
 
@@ -121,6 +122,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !t
+  , utBudget :: !T.Text
   }
   deriving (Show)
 
@@ -131,16 +133,12 @@ type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
 data EntryBin
   = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
   | ToRead ReadEntry
-  | ToInsert (Tx TxCommit)
+  | ToInsert (Tx CommitR)
 
 type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
 
 type BalEntry = InsertEntry AcntID CurID TagID
 
--- type DeferredKeyTx = Tx DeferredKeyEntry
-
--- type KeyTx = Tx KeyEntry
-
 type TreeR = Tree ([T.Text], AccountRId)
 
 type MonadFinance = MonadReader DBState
@@ -253,6 +251,7 @@ data Tx k = Tx
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
+  , txBudget :: !T.Text
   }
   deriving (Generic, Show)
 
@@ -271,7 +270,8 @@ data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
-  , itxCommit :: !TxCommit
+  , itxCommit :: !CommitR
+  , itxBudget :: !T.Text
   }
   deriving (Generic)
 

lib/Internal/Utils.hs

@@ -677,6 +677,7 @@ lookupFinance
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
 
+-- TODO need to split out the balance map by budget name (epic facepalm)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
@@ -689,19 +690,21 @@ balanceTxs ebs =
       fmap (Just . Left) $
         liftInnerS $
           either rebalanceTotalEntrySet rebalanceFullEntrySet utx
-    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
-      modify $ mapAdd_ (reAcnt, reCurrency) reValue
+      modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
-      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
+      e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
-      es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
+      es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
       let tx =
+            -- TODO this is lame
             InsertTx
               { itxDescr = txDescr
               , itxDate = txDate
               , itxEntrySets = e :| es
               , itxCommit = txCommit
+              , itxBudget = txBudget
               }
       return $ Just $ Right tx
     fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
@@ -712,7 +715,7 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate
 
-type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
+type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational
 
 data UpdateEntryType a b
   = UET_ReadOnly UE_RO
@@ -725,14 +728,13 @@ rebalanceTotalEntrySet
   UpdateEntrySet
     { utFrom0 = (f0, f0links)
     , utTo0
-    , -- , utPairs
+    , utFromUnk
-    utFromUnk
     , utToUnk
     , utFromRO
     , utToRO
     , utCurrency
-    , -- , utToUnkLink0
+    , utTotalValue
-    utTotalValue
+    , utBudget
     } =
     do
       (f0val, (tpairs, fs)) <-
@@ -782,10 +784,10 @@ rebalanceTotalEntrySet
       updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
       updateFixed e = do
         let v = unStaticValue $ ueValue e
-        modify $ mapAdd_ (ueAcnt e, utCurrency) v
+        modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
         return v
       updateUnknown e = do
-        let key = (ueAcnt e, utCurrency)
+        let key = (ueAcnt e, utCurrency, utBudget)
         curBal <- gets (M.findWithDefault 0 key)
         let v = case ueValue e of
               EVPercent p -> p * curBal
@@ -799,13 +801,12 @@ rebalanceFullEntrySet
   UpdateEntrySet
     { utFrom0
     , utTo0
-    , -- , utPairs
+    , utFromUnk
-    utFromUnk
     , utToUnk
     , utFromRO
     , utToRO
     , utCurrency
-    -- , utToUnkLink0
+    , utBudget
     } =
     do
       let (f_ro, f_lnkd) = case utFrom0 of
@@ -857,10 +858,10 @@ rebalanceFullEntrySet
       updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
       updateFixed e = do
         let v = unStaticValue $ ueValue e
-        modify $ mapAdd_ (ueAcnt e, utCurrency) v
+        modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
         return v
       updateUnknown e = do
-        let key = (ueAcnt e, utCurrency)
+        let key = (ueAcnt e, utCurrency, utBudget)
         curBal <- gets (M.findWithDefault 0 key)
         let v = case ueValue e of
               EVPercent p -> p * curBal
@@ -872,9 +873,11 @@ rebalanceFullEntrySet
 
 balanceSecondaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => SecondayEntrySet
+  => T.Text
+  -> SecondayEntrySet
   -> StateT EntryBals m InsertEntrySet
 balanceSecondaryEntrySet
+  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -884,15 +887,15 @@ balanceSecondaryEntrySet
       fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
       t0' <- resolveAcntAndTags t0
       ts' <- mapErrors resolveAcntAndTags ts
-      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
       fs'' <- mapErrors balFromEntry fs'
       let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
-      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+      let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
       ts'' <- mapErrors balToEntry ts'
       -- TODO wet
       let (acntID, sign) = eAcnt t0'
       let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
-      modify (mapAdd_ (acntID, curID) t0Val)
+      modify (mapAdd_ (acntID, curID, budgetName) t0Val)
       let t0'' =
             InsertEntry
               { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
@@ -911,9 +914,11 @@ balanceSecondaryEntrySet
 
 balancePrimaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => PrimaryEntrySet
+  => T.Text
+  -> PrimaryEntrySet
   -> StateT EntryBals m InsertEntrySet
 balancePrimaryEntrySet
+  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -927,13 +932,13 @@ balancePrimaryEntrySet
       let tsres = mapErrors resolveAcntAndTags ts
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
-          let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+          let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
-          fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'
+          fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
 
           let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
 
-          let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+          let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
-          ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
+          ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
           return $
             InsertEntrySet
               { iesCurrency = curID
@@ -945,16 +950,17 @@ doEntries
   :: (MonadInsertError m)
   => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
+  -> T.Text
   -> Rational
   -> Entry (AccountRId, AcntSign) () TagRId
   -> [Entry (AccountRId, AcntSign) v TagRId]
   -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
-doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do
+doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
   es' <- mapErrors f es
   let e0val = tot - entrySum es'
   -- TODO not dry
   let s = fromIntegral $ sign2Int sign -- NOTE hack
-  modify (mapAdd_ (acntID, curID) e0val)
+  modify (mapAdd_ (acntID, curID, budgetName) e0val)
   let e' =
         InsertEntry
           { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
@@ -971,11 +977,12 @@ balanceLinked
   :: MonadInsertError m
   => Vector Rational
   -> CurrencyRId
+  -> T.Text
   -> Natural
   -> AccountRId
   -> LinkDeferred Rational
   -> StateT EntryBals m (Rational, Maybe DBDeferred)
-balanceLinked from curID precision acntID lg = case lg of
+balanceLinked from curID budgetName precision acntID lg = case lg of
   (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
     let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
     case res of
@@ -983,17 +990,18 @@ balanceLinked from curID precision acntID lg = case lg of
       -- TODO this error would be much more informative if I had access to the
       -- file from which it came
       Nothing -> throwError undefined
-  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID budgetName d
   where
     go s = negate . roundPrecision precision . (* s) . fromRational
 
 balanceDeferred
   :: CurrencyRId
   -> AccountRId
+  -> T.Text
   -> EntryValue Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID (EntryValue t v) = do
+balanceDeferred curID acntID budgetName (EntryValue t v) = do
-  newval <- findBalance acntID curID t v
+  newval <- findBalance acntID curID budgetName t v
   let d = case t of
         TFixed -> Nothing
         TBalance -> Just $ EntryBalance v
@@ -1004,12 +1012,13 @@ balanceEntry
   :: (MonadInsertError m)
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
+  -> T.Text
   -> Entry (AccountRId, AcntSign) v TagRId
   -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
-balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
+balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
   let s = fromIntegral $ sign2Int sign
   (newVal, deferred) <- f acntID eValue
-  modify (mapAdd_ (acntID, curID) newVal)
+  modify (mapAdd_ (acntID, curID, budgetName) newVal)
   return $
     InsertEntry
       { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
@@ -1029,11 +1038,12 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
 findBalance
   :: AccountRId
   -> CurrencyRId
+  -> T.Text
   -> TransferType
   -> Rational
   -> State EntryBals Rational
-findBalance acnt cur t v = do
+findBalance acnt cur name t v = do
-  curBal <- gets (M.findWithDefault 0 (acnt, cur))
+  curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
   return $ case t of
     TBalance -> v - curBal
     TPercent -> v * curBal
@@ -1041,19 +1051,21 @@ findBalance acnt cur t v = do
 
 expandTransfers
   :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
+  => CommitR
+  -> T.Text
   -> DaySpan
   -> [PairedTransfer]
-  -> m [Tx TxCommit]
+  -> m [Tx CommitR]
-expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
+expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
 
 expandTransfer
   :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
+  => CommitR
+  -> T.Text
   -> DaySpan
   -> PairedTransfer
-  -> m [Tx TxCommit]
+  -> m [Tx CommitR]
-expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
   txs <- mapErrors go transAmounts
   return $ concat txs
   where
@@ -1072,6 +1084,7 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
               , txPrimary = Right p
               , txOther = []
               , txDescr = desc
+              , txBudget = name
               }
 
 entryPair