ENH clean up (and hopefully fix) lots of balancing stuff

2023-07-05 22:30:24 -04:00 · 2023-07-05 22:30:24 -04:00 · dce3ff4166
parent d9709f565f
commit dce3ff4166
3 changed files with 211 additions and 242 deletions
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@ -422,21 +422,6 @@ whenHash_ t o f = do
  hs <- askDBState kmNewCommits
  if h `elem` hs then Just . (c,) <$> f else return Nothing

-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
--   let aRes = lookupAccountKey eAcnt
--   let cRes = lookupCurrencyKey feCurrency
--   let sRes = lookupAccountSign eAcnt
--   let tagRes = combineErrors $ fmap lookupTag eTags
--   -- TODO correct sign here?
--   -- TODO lenses would be nice here
--   combineError (combineError3 aRes cRes sRes (,,)) tagRes $
--     \(aid, cid, sign) tags ->
--       s
--         { feCurrency = cid
--         , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
--         }
-
 readUpdates
  :: (MonadInsertError m, MonadSqlQuery m)
  => [Int]
@ -584,24 +569,41 @@ splitTo from0 fromUnk (t0 :| ts) = do
    primary = uncurry makeUnkUE t0
    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e

-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
+-- | Match linked credit entries with unknown entries, returning a list of
+-- matches and non-matching (read-only) credit entries. ASSUME both lists are
+-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
+-- sorted.
 zipPaired
  :: [UEUnk]
  -> [(Int, NonEmpty (EntryRId, EntryR))]
  -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
 zipPaired = go ([], [])
  where
-    go (facc, tacc) (f : fs) ((ti, tls) : ts)
-      | ueIndex f == ti = do
-          tls' <- mapErrors makeLinkUnk tls
-          go ((f, NE.toList tls') : facc, tacc) fs ts
-      | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
-    go (facc, tacc) fs ts =
-      return
-        ( reverse facc ++ ((,[]) <$> fs)
-        , tacc ++ concatMap (toRO . snd) ts
-        )
-    toRO = NE.toList . fmap (makeRoUE . snd)
+    nolinks = ((,[]) <$>)
+    go acc fs [] = return $ first (nolinks fs ++) acc
+    go (facc, tacc) fs ((ti, tls) : ts) = do
+      let (lesser, rest) = L.span ((< ti) . ueIndex) fs
+      links <- NE.toList <$> mapErrors makeLinkUnk tls
+      let (nextLink, fs') = case rest of
+            (r0 : rs)
+              | ueIndex r0 == ti -> (Just (r0, links), rs)
+              | otherwise -> (Nothing, rest)
+            _ -> (Nothing, rest)
+      let acc' = (nolinks lesser ++ facc, tacc)
+      let ros = NE.toList $ makeRoUE . snd <$> tls
+      let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
+      go (f acc') fs' ts
+
+-- go (facc, tacc) (f : fs) ((ti, tls) : ts)
+--   | ueIndex f == ti = do
+--       tls' <- mapErrors makeLinkUnk tls
+--       go ((f, NE.toList tls') : facc, tacc) fs ts
+--   | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
+-- go (facc, tacc) fs ts =
+--   return
+--     ( reverse facc ++ ((,[]) <$> fs)
+--     , tacc ++ concatMap (toRO . snd) ts
+--     )

 makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
 makeLinkUnk (k, e) =
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@ -60,6 +60,7 @@ data DBUpdates = DBUpdates
  , duNewAcntIds :: ![Entity AccountR]
  , duNewCurrencyIds :: ![Entity CurrencyR]
  }
+  deriving (Show)

 type CurrencyM = Reader CurrencyMap

@ -135,10 +136,6 @@ data EntryBin
  | ToRead ReadEntry
  | ToInsert (Tx CommitR)

-type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
-
-type BalEntry = InsertEntry AcntID CurID TagID
-
 type TreeR = Tree ([T.Text], AccountRId)

 type MonadFinance = MonadReader DBState
@ -255,15 +252,15 @@ data Tx k = Tx
  }
  deriving (Generic, Show)

-data InsertEntry a c t = InsertEntry
+data InsertEntry = InsertEntry
  { ieDeferred :: !(Maybe DBDeferred)
-  , ieEntry :: !(Entry a Rational t)
+  , ieEntry :: !(Entry AccountRId Rational TagRId)
  }

 data InsertEntrySet = InsertEntrySet
  { iesCurrency :: !CurrencyRId
-  , iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
-  , iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  , iesFromEntries :: !(NonEmpty InsertEntry)
+  , iesToEntries :: !(NonEmpty InsertEntry)
  }

 data InsertTx = InsertTx
@ -290,8 +287,6 @@ data LinkDeferred a

 -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID

-- type BalEntry = InsertEntry AcntID CurID TagID
-
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip

 --------------------------------------------------------------------------------
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@ -677,7 +677,6 @@ 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]
@ -691,7 +690,7 @@ balanceTxs ebs =
        liftInnerS $
          either rebalanceTotalEntrySet rebalanceFullEntrySet utx
    go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
-      modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
+      modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
      return Nothing
    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
      e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
@ -715,18 +714,20 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate

-type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational
+type BCKey = (CurrencyRId, Text)

-data UpdateEntryType a b
-  = UET_ReadOnly UE_RO
-  | UET_Unk a
-  | UET_Linked b
+type ABCKey = (AccountRId, BCKey)
+
+type EntryBals = M.Map ABCKey Rational
+
+--------------------------------------------------------------------------------
+-- rebalancing

 -- TODO make sure new values are rounded properly here
 rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceTotalEntrySet
  UpdateEntrySet
-    { utFrom0 = (f0, f0links)
+    { utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links)
    , utTo0
    , utFromUnk
    , utToUnk
@ -737,64 +738,14 @@ rebalanceTotalEntrySet
    , utBudget
    } =
    do
-      (f0val, (tpairs, fs)) <-
-        fmap (second partitionEithers) $
-          foldM goFrom (utTotalValue, []) $
-            L.sortOn idx $
-              (UET_ReadOnly <$> utFromRO)
-                ++ (UET_Linked <$> utFromUnk)
-      let f0' = f0 {ueValue = StaticValue f0val}
-      let tsLink0 = fmap (unlink (-f0val)) f0links
-      (t0val, tsUnk) <-
-        fmap (second catMaybes) $
-          foldM goTo (-utTotalValue, []) $
-            L.sortOn idx2 $
-              (UET_Linked <$> (tpairs ++ tsLink0))
-                ++ (UET_Unk <$> utToUnk)
-                ++ (UET_ReadOnly <$> utToRO)
-      let t0 = utTo0 {ueValue = StaticValue t0val}
-      return (f0' : fs ++ (t0 : tsUnk))
+      (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
+      let f0val = utTotalValue - fval
+      modify $ mapAdd_ (f0Acnt, bc) f0val
+      let tsLinked = tpairs ++ (unlink f0val <$> f0links)
+      ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
+      return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
    where
-      project f _ _ (UET_ReadOnly e) = f e
-      project _ f _ (UET_Unk e) = f e
-      project _ _ f (UET_Linked p) = f p
-      idx = project ueIndex ueIndex (ueIndex . fst)
-      idx2 = project ueIndex ueIndex ueIndex
-      -- TODO the sum accumulator thing is kinda awkward
-      goFrom (tot, es) (UET_ReadOnly e) = do
-        v <- updateFixed e
-        return (tot - v, es)
-      goFrom (tot, esPrev) (UET_Unk e) = do
-        v <- updateUnknown e
-        return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
-      goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
-        v <- updateUnknown e0
-        let e0' = Right $ e0 {ueValue = StaticValue v}
-        let es' = fmap (Left . unlink (-v)) es
-        return (tot - v, (e0' : es') ++ esPrev)
-      goTo (tot, esPrev) (UET_ReadOnly e) = do
-        v <- updateFixed e
-        return (tot - v, esPrev)
-      goTo (tot, esPrev) (UET_Linked e) = do
-        v <- updateFixed e
-        return (tot - v, Just e : esPrev)
-      goTo (tot, esPrev) (UET_Unk e) = do
-        v <- updateUnknown e
-        return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
-      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
-      updateFixed e = do
-        let v = unStaticValue $ ueValue e
-        modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
-        return v
-      updateUnknown e = do
-        let key = (ueAcnt e, utCurrency, utBudget)
-        curBal <- gets (M.findWithDefault 0 key)
-        let v = case ueValue e of
-              EVPercent p -> p * curBal
-              EVBalance p -> p - curBal
-        modify $ mapAdd_ key v
-        return v
-      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
+      bc = (utCurrency, utBudget)

 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@ -809,108 +760,92 @@ rebalanceFullEntrySet
    , utBudget
    } =
    do
-      let (f_ro, f_lnkd) = case utFrom0 of
+      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
+      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
+      return (fs ++ ts)
+    where
+      (rs, ls) = case utFrom0 of
        Left x -> (x : utFromRO, utFromUnk)
        Right x -> (utFromRO, x : utFromUnk)
-      (tpairs, fs) <-
-        fmap partitionEithers $
-          foldM goFrom [] $
+      bc = (utCurrency, utBudget)
+
+rebalanceDebit
+  :: BCKey
+  -> [UE_RO]
+  -> [(UEUnk, [UELink])]
+  -> State EntryBals (Rational, [UEBalanced], [UEBalanced])
+rebalanceDebit k ro linked = do
+  (tot, (tpairs, fs)) <-
+    fmap (second (partitionEithers . concat)) $
+      sumM goFrom $
        L.sortOn idx $
-              (UET_ReadOnly <$> f_ro)
-                ++ (UET_Linked <$> f_lnkd)
-      tsUnk <-
-        fmap catMaybes $
-          foldM goTo [] $
-            L.sortOn idx2 $
-              (UET_Linked <$> tpairs)
-                ++ (UET_Unk <$> utToUnk)
-                ++ (UET_ReadOnly <$> utToRO)
-      let t0val = -(entrySum fs + entrySum tsUnk)
-      let t0 = utTo0 {ueValue = t0val}
-      return (fs ++ (t0 : tsUnk))
+          (Left <$> ro) ++ (Right <$> linked)
+  return (tot, fs, tpairs)
  where
-      project f _ _ (UET_ReadOnly e) = f e
-      project _ f _ (UET_Unk e) = f e
-      project _ _ f (UET_Linked p) = f p
-      idx = project ueIndex ueIndex (ueIndex . fst)
-      idx2 = project ueIndex ueIndex ueIndex
-      -- TODO the sum accumulator thing is kinda awkward
-      goFrom es (UET_ReadOnly e) = do
-        _ <- updateFixed e
-        return es
-      goFrom esPrev (UET_Unk e) = do
-        v <- updateUnknown e
-        return $ Right e {ueValue = StaticValue v} : esPrev
-      goFrom esPrev (UET_Linked (e0, es)) = do
-        v <- updateUnknown e0
+    idx = either ueIndex (ueIndex . fst)
+    goFrom (Left e) = (,[]) <$> updateFixed k e
+    goFrom (Right (e0, es)) = do
+      v <- updateUnknown k e0
      let e0' = Right $ e0 {ueValue = StaticValue v}
-        let es' = fmap (Left . unlink (-v)) es
-        return $ (e0' : es') ++ esPrev
-      goTo esPrev (UET_ReadOnly e) = do
-        _ <- updateFixed e
-        return esPrev
-      goTo esPrev (UET_Linked e) = do
-        _ <- updateFixed e
-        return $ Just e : esPrev
-      goTo esPrev (UET_Unk e) = do
-        v <- updateUnknown e
-        return $ Just e {ueValue = StaticValue v} : esPrev
-      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
-      updateFixed e = do
+      let es' = Left . unlink v <$> es
+      return (v, e0' : es')
+
+unlink :: Rational -> UELink -> UEBalanced
+unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
+
+rebalanceCredit
+  :: BCKey
+  -> Rational
+  -> UEBlank
+  -> [UEUnk]
+  -> [UE_RO]
+  -> [UEBalanced]
+  -> State EntryBals [UEBalanced]
+rebalanceCredit k tot t0 us rs bs = do
+  (tval, ts) <-
+    fmap (second catMaybes) $
+      sumM goTo $
+        L.sortOn idx $
+          (UETLinked <$> bs)
+            ++ (UETUnk <$> us)
+            ++ (UETReadOnly <$> rs)
+  return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
+  where
+    idx = projectUET ueIndex ueIndex ueIndex
+    goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
+    goTo (UETLinked e) = (,Just e) <$> updateFixed k e
+    goTo (UETUnk e) = do
+      v <- updateUnknown k e
+      return (v, Just $ e {ueValue = StaticValue v})
+
+data UpdateEntryType a b
+  = UETReadOnly UE_RO
+  | UETUnk a
+  | UETLinked b
+
+projectUET :: (UE_RO -> c) -> (a -> c) -> (b -> c) -> UpdateEntryType a b -> c
+projectUET f _ _ (UETReadOnly e) = f e
+projectUET _ f _ (UETUnk e) = f e
+projectUET _ _ f (UETLinked p) = f p
+
+updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Rational
+updateFixed k e = do
  let v = unStaticValue $ ueValue e
-        modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
+  modify $ mapAdd_ (ueAcnt e, k) v
  return v
-      updateUnknown e = do
-        let key = (ueAcnt e, utCurrency, utBudget)
+
+updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
+updateUnknown k e = do
+  let key = (ueAcnt e, k)
  curBal <- gets (M.findWithDefault 0 key)
  let v = case ueValue e of
        EVPercent p -> p * curBal
        EVBalance p -> p - curBal
  modify $ mapAdd_ key v
  return v
-      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
-      entrySum = sum . fmap ueValue

-balanceSecondaryEntrySet
-  :: (MonadInsertError m, MonadFinance m)
-  => T.Text
-  -> SecondayEntrySet
-  -> StateT EntryBals m InsertEntrySet
-balanceSecondaryEntrySet
-  budgetName
-  EntrySet
-    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
-    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
-    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
-    } =
-    do
-      fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
-      t0' <- resolveAcntAndTags t0
-      ts' <- mapErrors resolveAcntAndTags ts
-      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 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, budgetName) t0Val)
-      let t0'' =
-            InsertEntry
-              { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
-              , ieDeferred = Nothing
-              }
-      -- TODO don't record index here, just keep them in order and let the
-      -- insertion function deal with assigning the index
-      return $
-        InsertEntrySet
-          { iesCurrency = curID
-          , iesFromEntries = fs''
-          , iesToEntries = t0'' :| ts''
-          }
-    where
-      entrySum = sum . fmap (eValue . ieEntry)
+--------------------------------------------------------------------------------
+-- balancing

 balancePrimaryEntrySet
  :: (MonadInsertError m, MonadFinance m)
@ -930,37 +865,72 @@ balancePrimaryEntrySet
      let t0res = resolveAcntAndTags t0
      let fsres = mapErrors resolveAcntAndTags fs
      let tsres = mapErrors resolveAcntAndTags ts
+      let bc = (curID, budgetName)
      combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
        \(f0', fs') (t0', ts') -> do
-          let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
-          fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
+          let balFrom = fmap liftInnerS . balanceDeferred
+          fs'' <- doEntries balFrom bc esTotalValue f0' fs'
+          balanceFinal bc (-esTotalValue) precision fs'' t0' ts'

-          let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
+balanceSecondaryEntrySet
+  :: (MonadInsertError m, MonadFinance m)
+  => T.Text
+  -> SecondayEntrySet
+  -> StateT EntryBals m InsertEntrySet
+balanceSecondaryEntrySet
+  budgetName
+  EntrySet
+    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
+    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
+    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+    } =
+    do
+      let fsRes = mapErrors resolveAcntAndTags (f0 :| fs)
+      let t0Res = resolveAcntAndTags t0
+      let tsRes = mapErrors resolveAcntAndTags ts
+      combineErrorM fsRes (combineError t0Res tsRes (,)) $ \fs' (t0', ts') -> do
+        fs'' <- mapErrors balFrom fs'
+        let tot = entrySum (NE.toList fs'')
+        balanceFinal bc (-tot) precision fs'' t0' ts'
+    where
+      entrySum = sum . fmap (eValue . ieEntry)
+      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
+      bc = (curID, budgetName)

-          let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
-          ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
+balanceFinal
+  :: (MonadInsertError m)
+  => BCKey
+  -> Rational
+  -> Natural
+  -> NonEmpty InsertEntry
+  -> Entry (AccountRId, AcntSign) () TagRId
+  -> [Entry (AccountRId, AcntSign) (LinkDeferred Rational) TagRId]
+  -> StateT EntryBals m InsertEntrySet
+balanceFinal k@(curID, _) tot precision fs t0 ts = do
+  let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
+  let balTo = balanceLinked fv precision
+  ts' <- doEntries balTo k tot t0 ts
  return $
    InsertEntrySet
      { iesCurrency = curID
-              , iesFromEntries = fs''
-              , iesToEntries = ts''
+      , iesFromEntries = fs
+      , iesToEntries = ts'
      }

 doEntries
  :: (MonadInsertError m)
-  => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
-  -> CurrencyRId
-  -> T.Text
+  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  -> BCKey
  -> Rational
  -> Entry (AccountRId, AcntSign) () TagRId
  -> [Entry (AccountRId, AcntSign) v TagRId]
-  -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
-doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
-  es' <- mapErrors f es
+  -> StateT EntryBals m (NonEmpty InsertEntry)
+doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
+  es' <- mapErrors (balanceEntry f k) es
  let e0val = tot - entrySum es'
  -- TODO not dry
  let s = fromIntegral $ sign2Int sign -- NOTE hack
-  modify (mapAdd_ (acntID, curID, budgetName) e0val)
+  modify (mapAdd_ (acntID, k) e0val)
  let e' =
        InsertEntry
          { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
@ -976,13 +946,11 @@ liftInnerS = mapStateT (return . runIdentity)
 balanceLinked
  :: MonadInsertError m
  => Vector Rational
-  -> CurrencyRId
-  -> T.Text
  -> Natural
-  -> AccountRId
+  -> ABCKey
  -> LinkDeferred Rational
  -> StateT EntryBals m (Rational, Maybe DBDeferred)
-balanceLinked from curID budgetName precision acntID lg = case lg of
+balanceLinked from precision k lg = case lg of
  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
    case res of
@ -990,18 +958,16 @@ balanceLinked from curID budgetName 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 budgetName d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred k d
  where
    go s = negate . roundPrecision precision . (* s) . fromRational

 balanceDeferred
-  :: CurrencyRId
-  -> AccountRId
-  -> T.Text
+  :: ABCKey
  -> EntryValue Rational
  -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID budgetName (EntryValue t v) = do
-  newval <- findBalance acntID curID budgetName t v
+balanceDeferred k (EntryValue t v) = do
+  newval <- findBalance k t v
  let d = case t of
        TFixed -> Nothing
        TBalance -> Just $ EntryBalance v
@ -1010,15 +976,14 @@ balanceDeferred curID acntID budgetName (EntryValue t v) = do

 balanceEntry
  :: (MonadInsertError m)
-  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-  -> CurrencyRId
-  -> T.Text
+  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  -> BCKey
  -> Entry (AccountRId, AcntSign) v TagRId
-  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
-balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
+  -> StateT EntryBals m InsertEntry
+balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
  let s = fromIntegral $ sign2Int sign
-  (newVal, deferred) <- f acntID eValue
-  modify (mapAdd_ (acntID, curID, budgetName) newVal)
+  (newVal, deferred) <- f (acntID, k) eValue
+  modify (mapAdd_ (acntID, k) newVal)
  return $
    InsertEntry
      { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
@ -1036,19 +1001,20 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}

 findBalance
-  :: AccountRId
-  -> CurrencyRId
-  -> T.Text
+  :: ABCKey
  -> TransferType
  -> Rational
  -> State EntryBals Rational
-findBalance acnt cur name t v = do
-  curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
+findBalance k t v = do
+  curBal <- gets (M.findWithDefault 0 k)
  return $ case t of
    TBalance -> v - curBal
    TPercent -> v * curBal
    TFixed -> v

+--------------------------------------------------------------------------------
+-- transfers
+
 expandTransfers
  :: (MonadInsertError m, MonadFinance m)
  => CommitR
@ -1122,3 +1088,9 @@ withDates
 withDates bounds dp f = do
  days <- liftExcept $ expandDatePat bounds dp
  combineErrors $ fmap f days
+
+sumM :: (Monad m, Num s) => (a -> m (s, b)) -> [a] -> m (s, [b])
+sumM f = mapAccumM (\s -> fmap (first (+ s)) . f) 0
+
+mapAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
+mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])