FIX separate running totals by budget label

2023-07-04 10:35:11 -04:00 · 2023-07-04 10:35:11 -04:00 · d9709f565f
parent 8c9dc1e970
commit d9709f565f
6 changed files with 110 additions and 87 deletions
--- a/lib/Internal/Budget.hs
+++ b/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 tc intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers tc budgetSpan bgtTransfers
+          let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers key bgtLabel 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)
-allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
+  -> m (Tx CommitR)
+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]
-  -> m [Tx TxCommit]
+  -> [Tx CommitR]
+  -> 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
--- a/lib/Internal/Database.hs
+++ b/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
-    getCommit (BudgetCommit c _) = c
+
+-- where
+--   getCommit (HistoryCommit c) = c
+--   getCommit (BudgetCommit c _) = c

 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
-  k <- insert $ TransactionR c itxDate itxDescr
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
+  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
-      ek <- insertEntry k i e
-      case itxCommit of
-        BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
-        _ -> return ()
+    go k i e = void $ insertEntry k i e
+
+-- case itxCommit of
+--   BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
+--   _ -> return ()

 insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
 insertEntry
--- a/lib/Internal/History.hs
+++ b/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"
--- a/lib/Internal/Types/Database.hs
+++ b/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
--- a/lib/Internal/Types/Main.hs
+++ b/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)

--- a/lib/Internal/Utils.hs
+++ b/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
-      modify $ mapAdd_ (reAcnt, reCurrency) reValue
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
+      modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
      return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
-      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
+      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
-          fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'
+          let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
+          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
-          ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
+          let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
+          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
-  newval <- findBalance acntID curID t v
+balanceDeferred curID acntID budgetName (EntryValue t v) = do
+  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
-  curBal <- gets (M.findWithDefault 0 (acnt, cur))
+findBalance acnt cur name t v = do
+  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]
-expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
+  -> m [Tx CommitR]
+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]
-expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+  -> m [Tx CommitR]
+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