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

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)
+    nolinks = ((,[]) <$>)
-      | ueIndex f == ti = do
+    go acc fs [] = return $ first (nolinks fs ++) acc
-          tls' <- mapErrors makeLinkUnk tls
+    go (facc, tacc) fs ((ti, tls) : ts) = do
-          go ((f, NE.toList tls') : facc, tacc) fs ts
+      let (lesser, rest) = L.span ((< ti) . ueIndex) fs
-      | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
+      links <- NE.toList <$> mapErrors makeLinkUnk tls
-    go (facc, tacc) fs ts =
+      let (nextLink, fs') = case rest of
-      return
+            (r0 : rs)
-        ( reverse facc ++ ((,[]) <$> fs)
+              | ueIndex r0 == ti -> (Just (r0, links), rs)
-        , tacc ++ concatMap (toRO . snd) ts
+              | otherwise -> (Nothing, rest)
-        )
+            _ -> (Nothing, rest)
-    toRO = NE.toList . fmap (makeRoUE . snd)
+      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) =

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))
+  , iesFromEntries :: !(NonEmpty InsertEntry)
-  , iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  , 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
 
 --------------------------------------------------------------------------------

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
+type ABCKey = (AccountRId, BCKey)
-  = UET_ReadOnly UE_RO
+
-  | UET_Unk a
+type EntryBals = M.Map ABCKey Rational
-  | UET_Linked b
+
+--------------------------------------------------------------------------------
+-- 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)) <-
+      (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
-        fmap (second partitionEithers) $
+      let f0val = utTotalValue - fval
-          foldM goFrom (utTotalValue, []) $
+      modify $ mapAdd_ (f0Acnt, bc) f0val
-            L.sortOn idx $
+      let tsLinked = tpairs ++ (unlink f0val <$> f0links)
-              (UET_ReadOnly <$> utFromRO)
+      ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
-                ++ (UET_Linked <$> utFromUnk)
+      return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
-      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))
     where
-      project f _ _ (UET_ReadOnly e) = f e
+      bc = (utCurrency, utBudget)
-      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)}
 
 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
-            Left x -> (x : utFromRO, utFromUnk)
+      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
-            Right x -> (utFromRO, x : utFromUnk)
+      return (fs ++ ts)
-      (tpairs, fs) <-
-        fmap partitionEithers $
-          foldM 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))
     where
-      project f _ _ (UET_ReadOnly e) = f e
+      (rs, ls) = case utFrom0 of
-      project _ f _ (UET_Unk e) = f e
+        Left x -> (x : utFromRO, utFromUnk)
-      project _ _ f (UET_Linked p) = f p
+        Right x -> (utFromRO, x : utFromUnk)
-      idx = project ueIndex ueIndex (ueIndex . fst)
+      bc = (utCurrency, utBudget)
-      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
-        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 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)}
-      entrySum = sum . fmap ueValue
 
-balanceSecondaryEntrySet
+rebalanceDebit
-  :: (MonadInsertError m, MonadFinance m)
+  :: BCKey
-  => T.Text
+  -> [UE_RO]
-  -> SecondayEntrySet
+  -> [(UEUnk, [UELink])]
-  -> StateT EntryBals m InsertEntrySet
+  -> State EntryBals (Rational, [UEBalanced], [UEBalanced])
-balanceSecondaryEntrySet
+rebalanceDebit k ro linked = do
-  budgetName
+  (tot, (tpairs, fs)) <-
-  EntrySet
+    fmap (second (partitionEithers . concat)) $
-    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
+      sumM goFrom $
-    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
+        L.sortOn idx $
-    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+          (Left <$> ro) ++ (Right <$> linked)
-    } =
+  return (tot, fs, tpairs)
-    do
+  where
-      fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
+    idx = either ueIndex (ueIndex . fst)
-      t0' <- resolveAcntAndTags t0
+    goFrom (Left e) = (,[]) <$> updateFixed k e
-      ts' <- mapErrors resolveAcntAndTags ts
+    goFrom (Right (e0, es)) = do
-      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
+      v <- updateUnknown k e0
-      fs'' <- mapErrors balFromEntry fs'
+      let e0' = Right $ e0 {ueValue = StaticValue v}
-      let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
+      let es' = Left . unlink v <$> es
-      let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
+      return (v, e0' : es')
-      ts'' <- mapErrors balToEntry ts'
+
-      -- TODO wet
+unlink :: Rational -> UELink -> UEBalanced
-      let (acntID, sign) = eAcnt t0'
+unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
-      let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
+
-      modify (mapAdd_ (acntID, curID, budgetName) t0Val)
+rebalanceCredit
-      let t0'' =
+  :: BCKey
-            InsertEntry
+  -> Rational
-              { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
+  -> UEBlank
-              , ieDeferred = Nothing
+  -> [UEUnk]
-              }
+  -> [UE_RO]
-      -- TODO don't record index here, just keep them in order and let the
+  -> [UEBalanced]
-      -- insertion function deal with assigning the index
+  -> State EntryBals [UEBalanced]
-      return $
+rebalanceCredit k tot t0 us rs bs = do
-        InsertEntrySet
+  (tval, ts) <-
-          { iesCurrency = curID
+    fmap (second catMaybes) $
-          , iesFromEntries = fs''
+      sumM goTo $
-          , iesToEntries = t0'' :| ts''
+        L.sortOn idx $
-          }
+          (UETLinked <$> bs)
-    where
+            ++ (UETUnk <$> us)
-      entrySum = sum . fmap (eValue . ieEntry)
+            ++ (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, k) v
+  return v
+
+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
+
+--------------------------------------------------------------------------------
+-- 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
+          let balFrom = fmap liftInnerS . balanceDeferred
-          fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
+          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
+balanceFinal
-          ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
+  :: (MonadInsertError m)
-          return $
+  => BCKey
-            InsertEntrySet
+  -> Rational
-              { iesCurrency = curID
+  -> Natural
-              , iesFromEntries = fs''
+  -> NonEmpty InsertEntry
-              , iesToEntries = ts''
+  -> 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'
+      }
 
 doEntries
   :: (MonadInsertError m)
-  => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
+  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-  -> CurrencyRId
+  -> BCKey
-  -> T.Text
   -> Rational
   -> Entry (AccountRId, AcntSign) () TagRId
   -> [Entry (AccountRId, AcntSign) v TagRId]
-  -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  -> StateT EntryBals m (NonEmpty InsertEntry)
-doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
+doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
-  es' <- mapErrors f es
+  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
+  :: ABCKey
-  -> AccountRId
-  -> T.Text
   -> EntryValue Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID budgetName (EntryValue t v) = do
+balanceDeferred k (EntryValue t v) = do
-  newval <- findBalance acntID curID budgetName t v
+  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))
+  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-  -> CurrencyRId
+  -> BCKey
-  -> T.Text
   -> Entry (AccountRId, AcntSign) v TagRId
-  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
+  -> StateT EntryBals m InsertEntry
-balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
+balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
   let s = fromIntegral $ sign2Int sign
-  (newVal, deferred) <- f acntID eValue
+  (newVal, deferred) <- f (acntID, k) eValue
-  modify (mapAdd_ (acntID, curID, budgetName) newVal)
+  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
+  :: ABCKey
-  -> CurrencyRId
-  -> T.Text
   -> TransferType
   -> Rational
   -> State EntryBals Rational
-findBalance acnt cur name t v = do
+findBalance k t v = do
-  curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
+  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, [])