REF move commont stuff to common modules

app/Main.hs

@@ -163,25 +163,26 @@ runDumpAccountKeys c = do
 runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  let (hTs, hSs) = splitHistory $ statements config
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
   handle err $ do
     -- _ <- askLoggerIO
 
-    -- get the current DB state
+    -- Get the current DB state.
     (state, updates) <- runSqlQueryT pool $ do
       runMigration migrateAll
       liftIOExceptT $ getDBState config
 
-    -- read desired statements from disk
+    -- Read raw transactions according to state. If a transaction is already in
+    -- the database, don't read it but record the commit so we can update it.
     (rus, is) <-
       flip runReaderT state $ do
+        let (hTs, hSs) = splitHistory $ statements config
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
 
-    -- update the DB
+    -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       res <- runExceptT $ do
         -- TODO taking out the hash is dumb

lib/Internal/Budget.hs

@@ -3,7 +3,6 @@ module Internal.Budget (readBudget) where
 import Control.Monad.Except
 import Data.Foldable
 import Internal.Database
-import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -13,17 +12,6 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
--- each budget (designated at the top level by a 'name') is processed in the
--- following steps
--- 1. expand all transactions given the desired date range and date patterns for
---    each directive in the budget
--- 2. sort all transactions by date
--- 3. propagate all balances forward, and while doing so assign values to each
---    transaction (some of which depend on the 'current' balance of the
---    target account)
--- 4. assign shadow transactions
--- 5. insert all transactions
-
 readBudget
   :: (MonadInsertError m, MonadFinance m)
   => Budget
@@ -47,7 +35,7 @@ readBudget
           (intAllos, _) <- combineError intAlloRes acntRes (,)
           let tc = BudgetCommit key bgtLabel
           let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers
+          let res2 = expandTransfers tc budgetSpan bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
@@ -354,9 +342,6 @@ allocatePost precision aftertax = fmap (fmap go)
             then aftertax * roundPrecision 3 v / 100
             else roundPrecision precision v
 
---------------------------------------------------------------------------------
--- Standalone Transfer
-
 --------------------------------------------------------------------------------
 -- shadow transfers
 
@@ -403,12 +388,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
 alloAcnt :: Allocation w v -> AcntID
 alloAcnt = taAcnt . alloTo
 
-data UnbalancedValue = UnbalancedValue
-  { cvType :: !TransferType
-  , cvValue :: !Rational
-  }
-  deriving (Show)
-
 type IntAllocations =
   ( [DaySpanAllocation PretaxValue]
   , [DaySpanAllocation TaxValue]

lib/Internal/Database.hs

@@ -15,6 +15,8 @@ module Internal.Database
   , insertEntry
   , resolveEntry
   , readUpdates
+  , insertAll
+  , updateTx
   )
 where
 
@@ -33,6 +35,7 @@ import Database.Persist.Sqlite hiding
   , insertKey
   , insert_
   , runMigration
+  , update
   , (==.)
   , (||.)
   )
@@ -598,3 +601,33 @@ makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
+
+insertAll
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => [EntryBin]
+  -> m ()
+insertAll ebs = do
+  (toUpdate, toInsert) <- balanceTxs ebs
+  mapM_ updateTx toUpdate
+  forM_ (groupWith itxCommit toInsert) $
+    \(c, ts) -> do
+      ck <- insert $ getCommit c
+      mapM_ (insertTx ck) ts
+  where
+    getCommit (HistoryCommit c) = c
+    getCommit (BudgetCommit c _) = c
+
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
+insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
+  let anyDeferred = any (isJust . feDeferred) itxEntries
+  k <- insert $ TransactionR c itxDate itxDescr anyDeferred
+  mapM_ (go k) itxEntries
+  where
+    go k tx = do
+      ek <- insertEntry k tx
+      case itxCommit of
+        BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
+        _ -> return ()
+
+updateTx :: MonadSqlQuery m => UEBalanced -> m ()
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]

lib/Internal/History.hs

@@ -1,21 +1,13 @@
 module Internal.History
   ( readHistStmt
   , readHistTransfer
-  , insertAll
   , splitHistory
-  , balanceTxs
-  , updateTx
-  , entryPair_
-  , expandTransfers
-  , entryPair
   )
 where
 
 import Control.Monad.Except
 import Data.Csv
 import Data.Foldable
-import Database.Persist ((=.))
-import Database.Persist.Monad hiding (get)
 import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
@@ -24,20 +16,32 @@ import qualified RIO.ByteString.Lazy as BL
 import RIO.FilePath
 import qualified RIO.List as L
 import qualified RIO.Map as M
-import qualified RIO.NonEmpty as NE
-import RIO.State
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 
--- TODO unify this with the transfer system I use in the budget now
+-- NOTE keep statement and transfer readers separate because the former needs
+-- the IO monad, and thus will throw IO errors rather than using the ExceptT
+-- thingy
+splitHistory :: [History] -> ([PairedTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
+--------------------------------------------------------------------------------
+-- Transfers
+
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => PairedTransfer
   -> m (Either CommitR [Tx TxCommit])
 readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
   bounds <- askDBState kmStatementInterval
-  expandTransfer (HistoryCommit c) (Just bounds) ht
+  expandTransfer (HistoryCommit c) bounds ht
+
+--------------------------------------------------------------------------------
+-- Statements
 
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
@@ -49,172 +53,6 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do
   bounds <- askDBState kmStatementInterval
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
 
-splitHistory :: [History] -> ([PairedTransfer], [Statement])
-splitHistory = partitionEithers . fmap go
-  where
-    go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
-
-insertAll
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin]
-  -> m ()
-insertAll ebs = do
-  (toUpdate, toInsert) <- balanceTxs ebs
-  mapM_ updateTx toUpdate
-  forM_ (groupWith itxCommit toInsert) $
-    \(c, ts) -> do
-      ck <- insert $ getCommit c
-      mapM_ (insertTx ck) ts
-  where
-    getCommit (HistoryCommit c) = c
-    getCommit (BudgetCommit c _) = c
-
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
-  let anyDeferred = any (isJust . feDeferred) itxEntries
-  k <- insert $ TransactionR c itxDate itxDescr anyDeferred
-  mapM_ (go k) itxEntries
-  where
-    go k tx = do
-      ek <- insertEntry k tx
-      case itxCommit of
-        BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
-        _ -> return ()
-
-updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
-
---------------------------------------------------------------------------------
--- low-level transaction stuff
-
-expandTransfers
-  :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
-  -> Maybe DaySpan
-  -> [PairedTransfer]
-  -> m [Tx TxCommit]
-expandTransfers tc localInterval ts =
-  fmap (L.sortOn txDate . concat) $
-    combineErrors $
-      fmap (expandTransfer tc localInterval) ts
-
-expandTransfer
-  :: (MonadInsertError m, MonadFinance m)
-  => TxCommit
-  -> Maybe DaySpan
-  -> PairedTransfer
-  -> m [Tx TxCommit]
-expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  txs <- concat <$> mapErrors go transAmounts
-  return $ case ds of
-    Nothing -> txs
-    Just bounds -> filter (inDaySpan bounds . txDate) txs
-  where
-    go
-      Amount
-        { amtWhen = pat
-        , amtValue = TransferValue {tvVal = v, tvType = t}
-        , amtDesc = desc
-        } =
-        withDates pat $ \day -> do
-          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
-          return
-            Tx
-              { txCommit = tc
-              , txDate = day
-              , txPrimary = p
-              , txOther = []
-              , txDescr = desc
-              }
-
-entryPair
-  :: (MonadInsertError m, MonadFinance m)
-  => TaggedAcnt
-  -> TaggedAcnt
-  -> CurID
-  -> T.Text
-  -> Double
-  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
-entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
-
-entryPair_
-  :: (MonadInsertError m, MonadFinance m)
-  => (CurrencyPrec -> v -> v')
-  -> TaggedAcnt
-  -> TaggedAcnt
-  -> CurID
-  -> T.Text
-  -> v
-  -> m (EntrySet AcntID CurrencyPrec TagID Rational v')
-entryPair_ f from to curid com val = do
-  cp <- lookupCurrency curid
-  return $ pair cp from to (f cp val)
-  where
-    halfEntry :: a -> [t] -> HalfEntrySet a c t v
-    halfEntry a ts =
-      HalfEntrySet
-        { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
-        , hesOther = []
-        }
-    pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
-      EntrySet
-        { esCurrency = cp
-        , esTotalValue = v
-        , esFrom = halfEntry fa fts
-        , esTo = halfEntry ta tts
-        }
-
-withDates
-  :: (MonadFinance m, MonadInsertError m)
-  => DatePat
-  -> (Day -> m a)
-  -> m [a]
-withDates dp f = do
-  bounds <- askDBState kmBudgetInterval
-  days <- liftExcept $ expandDatePat bounds dp
-  combineErrors $ fmap f days
-
--- -- TODO tags here?
--- txPair
---   :: CommitR
---   -> Day
---   -> AcntID
---   -> AcntID
---   -> CurrencyPrec
---   -> TransferValue
---   -> T.Text
---   -> Tx TxCommit
--- txPair commit day from to cur (TransferValue t v) desc =
---   Tx
---     { txDescr = desc
---     , txDate = day
---     , txCommit = HistoryCommit commit
---     , txPrimary =
---         EntrySet
---           { esTotalValue = EntryValue t $ toRational v
---           , esCurrency = cur
---           , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
---           , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
---           }
---     , txOther = []
---     }
---   where
---     entry a =
---       Entry
---         { eAcnt = a
---         , eValue = ()
---         , eComment = ""
---         , eTags = []
---         }
-
--- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
--- resolveTx t@Tx {txEntries = ss} =
---   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
-
---------------------------------------------------------------------------------
--- Statements
-
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
@@ -423,279 +261,3 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchSkip -> (Nothing : matched, unmatched)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
-
-balanceTxs
-  :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin]
-  -> m ([UEBalanced], [InsertTx])
-balanceTxs ebs =
-  first concat . partitionEithers . catMaybes
-    <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
-  where
-    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
-    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
-      modify $ mapAdd_ (reAcnt, reCurrency) reValue
-      return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
-      e <- balanceEntrySet primaryBalance txPrimary
-      -- TODO this logic is really stupid, I'm balancing the total twice; fix
-      -- will likely entail making a separate data structure for txs derived
-      -- from transfers vs statements
-      let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
-      es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
-      let tx =
-            InsertTx
-              { itxDescr = txDescr
-              , itxDate = txDate
-              , itxEntries = concat $ e : es
-              , itxCommit = txCommit
-              }
-      return $ Just $ Right tx
-    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
-    secondaryBalance tot Entry {eAcnt} c val = case val of
-      Right (EntryValue t v) -> findBalance eAcnt c t v
-      Left v -> return $ toRational v * tot
-
-binDate :: EntryBin -> Day
-binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
-binDate (ToRead ReadEntry {reDate}) = reDate
-binDate (ToInsert Tx {txDate}) = txDate
-
-type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
-
-data UpdateEntryType a
-  = UET_ReadOnly UE_RO
-  | UET_Unk UEUnk
-  | UET_Linked a
-
--- TODO make sure new values are rounded properly here
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
-rebalanceEntrySet
-  UpdateEntrySet
-    { utFrom0
-    , utTo0
-    , utPairs
-    , utFromUnk
-    , utToUnk
-    , utFromRO
-    , utToRO
-    , utCurrency
-    , utToUnkLink0
-    , utTotalValue
-    } =
-    do
-      (f0val, (tpairs, fs)) <-
-        fmap (second partitionEithers) $
-          foldM goFrom (utTotalValue, []) $
-            L.sortOn idx $
-              (UET_ReadOnly <$> utFromRO)
-                ++ (UET_Unk <$> utFromUnk)
-                ++ (UET_Linked <$> utPairs)
-      let f0 = utFrom0 {ueValue = StaticValue f0val}
-      let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
-      (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
-      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) v
-        return v
-      updateUnknown e = do
-        let key = (ueAcnt e, utCurrency)
-        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)}
-
-balanceEntrySet
-  :: (MonadInsertError m, MonadFinance m)
-  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
-  -> DeferredEntrySet v
-  -> StateT EntryBals m [KeyEntry]
-balanceEntrySet
-  findTot
-  EntrySet
-    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
-    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
-    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
-    , esTotalValue
-    } =
-    do
-      -- 1. Resolve tag and accout ids in primary entries since we (might) need
-      --    them later to calculate the total value of the transaction.
-      let f0res = resolveAcntAndTags f0
-      let t0res = resolveAcntAndTags t0
-      combineErrorM f0res t0res $ \f0' t0' -> do
-        -- 2. Compute total value of transaction using the primary debit entry
-        tot <- liftInnerS $ findTot f0' curID esTotalValue
-
-        -- 3. Balance all debit entries (including primary). Note the negative
-        --    indices, which will signify them to be debit entries when updated
-        --    later.
-        let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
-        fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
-
-        -- 4. Build an array of debit values be linked as desired in credit entries
-        let fv = V.fromList $ fmap (eValue . feEntry) fs'
-
-        -- 4. Balance credit entries (including primary) analogously.
-        let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
-        ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
-        return $ fs' ++ ts'
-
-doEntries
-  :: (MonadInsertError m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
-  -> CurrencyRId
-  -> Rational
-  -> Entry AccountRId AcntSign TagRId
-  -> [Entry AcntID v TagID]
-  -> NonEmpty Int
-  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
-doEntries f curID tot e es (i0 :| iN) = do
-  es' <- mapErrors (uncurry f) $ zip iN es
-  let e0val = tot - entrySum es'
-  -- TODO not dry
-  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
-  modify (mapAdd_ (eAcnt e, curID) tot)
-  let e' =
-        InsertEntry
-          { feEntry = e {eValue = s * e0val}
-          , feCurrency = curID
-          , feDeferred = Nothing
-          , feIndex = i0
-          }
-  return $ e' : es'
-  where
-    entrySum = sum . fmap (eValue . feEntry)
-
-liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
-liftInnerS = mapStateT (return . runIdentity)
-
-balanceLinked
-  :: MonadInsertError m
-  => Vector Rational
-  -> CurrencyRId
-  -> Natural
-  -> AccountRId
-  -> LinkDeferred Rational
-  -> StateT EntryBals m (Rational, Maybe DBDeferred)
-balanceLinked from curID precision acntID lg = case lg of
-  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
-    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
-    case res of
-      Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
-      -- 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
-  where
-    go s = roundPrecision precision . (* s) . fromRational
-
-balanceDeferred
-  :: CurrencyRId
-  -> AccountRId
-  -> EntryValue Rational
-  -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID (EntryValue t v) = do
-  newval <- findBalance acntID curID t v
-  let d = case t of
-        TFixed -> Nothing
-        TBalance -> Just $ EntryBalance v
-        TPercent -> Just $ EntryPercent v
-  return (newval, d)
-
-balanceEntry
-  :: (MonadInsertError m, MonadFinance m)
-  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-  -> CurrencyRId
-  -> Int
-  -> Entry AcntID v TagID
-  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
-balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
-  let acntRes = lookupAccount eAcnt
-  let tagRes = mapErrors lookupTag eTags
-  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
-    let s = fromIntegral $ sign2Int sign
-    (newVal, deferred) <- f acntID eValue
-    modify (mapAdd_ (acntID, curID) newVal)
-    return $
-      InsertEntry
-        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
-        , feCurrency = curID
-        , feDeferred = deferred
-        , feIndex = idx
-        }
-
-resolveAcntAndTags
-  :: (MonadInsertError m, MonadFinance m)
-  => Entry AcntID v TagID
-  -> m (Entry AccountRId AcntSign TagRId)
-resolveAcntAndTags e@Entry {eAcnt, eTags} = do
-  let acntRes = lookupAccount eAcnt
-  let tagRes = mapErrors lookupTag eTags
-  -- TODO total hack, store account sign in the value field so I don't need to
-  -- make seperate tuple pair thing to haul it around. Weird, but it works.
-  combineError acntRes tagRes $
-    \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
-
-findBalance
-  :: AccountRId
-  -> CurrencyRId
-  -> TransferType
-  -> Rational
-  -> State EntryBals Rational
-findBalance acnt cur t v = do
-  curBal <- gets (M.findWithDefault 0 (acnt, cur))
-  return $ case t of
-    TBalance -> v - curBal
-    TPercent -> v * curBal
-    TFixed -> v
-
--- -- reimplementation from future version :/
--- mapAccumM
---   :: Monad m
---   => (s -> a -> m (s, b))
---   -> s
---   -> [a]
---   -> m (s, [b])
--- mapAccumM f s xs = foldrM go (s, []) xs
---   where
---     go x (s', acc) = second (: acc) <$> f s' x

lib/Internal/Utils.hs

@@ -60,6 +60,11 @@ module Internal.Utils
   , mapAdd_
   , groupKey
   , groupWith
+  , balanceTxs
+  , expandTransfers
+  , expandTransfer
+  , entryPair
+  , entryPair_
   )
 where
 
@@ -72,8 +77,10 @@ import RIO
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
+import RIO.State
 import qualified RIO.Text as T
 import RIO.Time
+import qualified RIO.Vector as V
 import Text.Regex.TDFA
 import Text.Regex.TDFA.Text
 
@@ -1021,3 +1028,350 @@ lookupFinance
   -> T.Text
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
+
+balanceTxs
+  :: (MonadInsertError m, MonadFinance m)
+  => [EntryBin]
+  -> m ([UEBalanced], [InsertTx])
+balanceTxs ebs =
+  first concat . partitionEithers . catMaybes
+    <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
+  where
+    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
+      modify $ mapAdd_ (reAcnt, reCurrency) reValue
+      return Nothing
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
+      e <- balanceEntrySet primaryBalance txPrimary
+      -- TODO this logic is really stupid, I'm balancing the total twice; fix
+      -- will likely entail making a separate data structure for txs derived
+      -- from transfers vs statements
+      let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
+      es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
+      let tx =
+            InsertTx
+              { itxDescr = txDescr
+              , itxDate = txDate
+              , itxEntries = concat $ e : es
+              , itxCommit = txCommit
+              }
+      return $ Just $ Right tx
+    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
+    secondaryBalance tot Entry {eAcnt} c val = case val of
+      Right (EntryValue t v) -> findBalance eAcnt c t v
+      Left v -> return $ toRational v * tot
+
+binDate :: EntryBin -> Day
+binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
+binDate (ToRead ReadEntry {reDate}) = reDate
+binDate (ToInsert Tx {txDate}) = txDate
+
+type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
+
+data UpdateEntryType a
+  = UET_ReadOnly UE_RO
+  | UET_Unk UEUnk
+  | UET_Linked a
+
+-- TODO make sure new values are rounded properly here
+rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceEntrySet
+  UpdateEntrySet
+    { utFrom0
+    , utTo0
+    , utPairs
+    , utFromUnk
+    , utToUnk
+    , utFromRO
+    , utToRO
+    , utCurrency
+    , utToUnkLink0
+    , utTotalValue
+    } =
+    do
+      (f0val, (tpairs, fs)) <-
+        fmap (second partitionEithers) $
+          foldM goFrom (utTotalValue, []) $
+            L.sortOn idx $
+              (UET_ReadOnly <$> utFromRO)
+                ++ (UET_Unk <$> utFromUnk)
+                ++ (UET_Linked <$> utPairs)
+      let f0 = utFrom0 {ueValue = StaticValue f0val}
+      let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
+      (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
+      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) v
+        return v
+      updateUnknown e = do
+        let key = (ueAcnt e, utCurrency)
+        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)}
+
+balanceEntrySet
+  :: (MonadInsertError m, MonadFinance m)
+  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
+  -> DeferredEntrySet v
+  -> StateT EntryBals m [KeyEntry]
+balanceEntrySet
+  findTot
+  EntrySet
+    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
+    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
+    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+    , esTotalValue
+    } =
+    do
+      -- 1. Resolve tag and accout ids in primary entries since we (might) need
+      --    them later to calculate the total value of the transaction.
+      let f0res = resolveAcntAndTags f0
+      let t0res = resolveAcntAndTags t0
+      combineErrorM f0res t0res $ \f0' t0' -> do
+        -- 2. Compute total value of transaction using the primary debit entry
+        tot <- liftInnerS $ findTot f0' curID esTotalValue
+
+        -- 3. Balance all debit entries (including primary). Note the negative
+        --    indices, which will signify them to be debit entries when updated
+        --    later.
+        let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+        fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
+
+        -- 4. Build an array of debit values be linked as desired in credit entries
+        let fv = V.fromList $ fmap (eValue . feEntry) fs'
+
+        -- 4. Balance credit entries (including primary) analogously.
+        let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+        ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
+        return $ fs' ++ ts'
+
+doEntries
+  :: (MonadInsertError m)
+  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
+  -> CurrencyRId
+  -> Rational
+  -> Entry AccountRId AcntSign TagRId
+  -> [Entry AcntID v TagID]
+  -> NonEmpty Int
+  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
+doEntries f curID tot e es (i0 :| iN) = do
+  es' <- mapErrors (uncurry f) $ zip iN es
+  let e0val = tot - entrySum es'
+  -- TODO not dry
+  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
+  modify (mapAdd_ (eAcnt e, curID) tot)
+  let e' =
+        InsertEntry
+          { feEntry = e {eValue = s * e0val}
+          , feCurrency = curID
+          , feDeferred = Nothing
+          , feIndex = i0
+          }
+  return $ e' : es'
+  where
+    entrySum = sum . fmap (eValue . feEntry)
+
+liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
+liftInnerS = mapStateT (return . runIdentity)
+
+balanceLinked
+  :: MonadInsertError m
+  => Vector Rational
+  -> CurrencyRId
+  -> Natural
+  -> AccountRId
+  -> LinkDeferred Rational
+  -> StateT EntryBals m (Rational, Maybe DBDeferred)
+balanceLinked from curID precision acntID lg = case lg of
+  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
+    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
+    case res of
+      Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
+      -- 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
+  where
+    go s = roundPrecision precision . (* s) . fromRational
+
+balanceDeferred
+  :: CurrencyRId
+  -> AccountRId
+  -> EntryValue Rational
+  -> State EntryBals (Rational, Maybe DBDeferred)
+balanceDeferred curID acntID (EntryValue t v) = do
+  newval <- findBalance acntID curID t v
+  let d = case t of
+        TFixed -> Nothing
+        TBalance -> Just $ EntryBalance v
+        TPercent -> Just $ EntryPercent v
+  return (newval, d)
+
+balanceEntry
+  :: (MonadInsertError m, MonadFinance m)
+  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  -> CurrencyRId
+  -> Int
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
+balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
+  let acntRes = lookupAccount eAcnt
+  let tagRes = mapErrors lookupTag eTags
+  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
+    let s = fromIntegral $ sign2Int sign
+    (newVal, deferred) <- f acntID eValue
+    modify (mapAdd_ (acntID, curID) newVal)
+    return $
+      InsertEntry
+        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
+        , feCurrency = curID
+        , feDeferred = deferred
+        , feIndex = idx
+        }
+
+resolveAcntAndTags
+  :: (MonadInsertError m, MonadFinance m)
+  => Entry AcntID v TagID
+  -> m (Entry AccountRId AcntSign TagRId)
+resolveAcntAndTags e@Entry {eAcnt, eTags} = do
+  let acntRes = lookupAccount eAcnt
+  let tagRes = mapErrors lookupTag eTags
+  -- TODO total hack, store account sign in the value field so I don't need to
+  -- make seperate tuple pair thing to haul it around. Weird, but it works.
+  combineError acntRes tagRes $
+    \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
+
+findBalance
+  :: AccountRId
+  -> CurrencyRId
+  -> TransferType
+  -> Rational
+  -> State EntryBals Rational
+findBalance acnt cur t v = do
+  curBal <- gets (M.findWithDefault 0 (acnt, cur))
+  return $ case t of
+    TBalance -> v - curBal
+    TPercent -> v * curBal
+    TFixed -> v
+
+expandTransfers
+  :: (MonadInsertError m, MonadFinance m)
+  => TxCommit
+  -> DaySpan
+  -> [PairedTransfer]
+  -> m [Tx TxCommit]
+expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
+
+expandTransfer
+  :: (MonadInsertError m, MonadFinance m)
+  => TxCommit
+  -> DaySpan
+  -> PairedTransfer
+  -> m [Tx TxCommit]
+expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+  txs <- mapErrors go transAmounts
+  return $ filter (inDaySpan bounds . txDate) $ concat txs
+  where
+    go
+      Amount
+        { amtWhen = pat
+        , amtValue = TransferValue {tvVal = v, tvType = t}
+        , amtDesc = desc
+        } =
+        withDates pat $ \day -> do
+          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
+          return
+            Tx
+              { txCommit = tc
+              , txDate = day
+              , txPrimary = p
+              , txOther = []
+              , txDescr = desc
+              }
+
+entryPair
+  :: (MonadInsertError m, MonadFinance m)
+  => TaggedAcnt
+  -> TaggedAcnt
+  -> CurID
+  -> T.Text
+  -> Double
+  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
+
+entryPair_
+  :: (MonadInsertError m, MonadFinance m)
+  => (CurrencyPrec -> v -> v')
+  -> TaggedAcnt
+  -> TaggedAcnt
+  -> CurID
+  -> T.Text
+  -> v
+  -> m (EntrySet AcntID CurrencyPrec TagID Rational v')
+entryPair_ f from to_ curid com val = do
+  cp <- lookupCurrency curid
+  return $ pair cp from to_ (f cp val)
+  where
+    halfEntry :: a -> [t] -> HalfEntrySet a c t v
+    halfEntry a ts =
+      HalfEntrySet
+        { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
+        , hesOther = []
+        }
+    pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
+      EntrySet
+        { esCurrency = cp
+        , esTotalValue = v
+        , esFrom = halfEntry fa fts
+        , esTo = halfEntry ta tts
+        }
+
+withDates
+  :: (MonadFinance m, MonadInsertError m)
+  => DatePat
+  -> (Day -> m a)
+  -> m [a]
+withDates dp f = do
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $ fmap f days