From 776a10ba118454d2d132b952a046df15835f7f6a Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 10 Jun 2023 21:30:30 -0400
Subject: [PATCH 01/59] ENH allow multiple entries on credit side of
 transaction statement getter

---
 dhall/Types.dhall           | 57 ++++++++++++++++++++++++---------
 lib/Internal/Types/Dhall.hs | 19 +++++------
 lib/Internal/Types/Main.hs  |  2 ++
 lib/Internal/Utils.hs       | 63 ++++++++++++++++++++++++++-----------
 4 files changed, 98 insertions(+), 43 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 2e584b2..ff279eb 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -472,9 +472,19 @@ let Entry =
             List t
         }
 
-let EntryGetter =
+let FromEntryGetter =
     {-
-    Means for getting an entry from a given row in a statement
+    Means for getting an entry from a given row in a statement to apply to the
+    credit side of the transaction.
+    -}
+      { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID
+      , default = { eValue = None EntryNumGetter, eComment = "" }
+      }
+
+let ToEntryGetter =
+    {-
+    Means for getting an entry from a given row in a statement to apply to the
+    debit side of the transaction.
     -}
       { Type =
           Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
@@ -488,21 +498,37 @@ let TxGetter =
     Note that N-1 entries need to be specified to make a transaction, as the
     Nth entry will be balanced with the others.
     -}
-      { tgEntries :
+      { tgFromAcnt :
+          {-
+          Account from which this transaction will be balanced. The value of
+          the transaction will be assigned to this account unless other from
+          entries are specified (see below).
+          -}
+          EntryAcntGetter
+      , tgFromCurrency :
+          {-
+          Currency to assign to the account/value denoted by 'tgFromAcnt'
+          above.
+          -}
+          EntryCurGetter
+      , tgFromEntries :
+          {-
+          Means of getting additional entries from which this transaction will
+          be balanced (minimum 0). If this list is empty, the total value of the
+          transaction will be assigned to the value defined by 'tgFromAcnt'.
+          Otherwise, the entries specified here will be added to the credit side
+          of this transaction, and their sum value will be subtracted from the
+          total value of the transaction and assigned to 'tgFromAcnt'.
+
+          This is useful for situations where a particular transaction denotes
+          values that come from multiple subaccounts.
+          -}
+          List FromEntryGetter.Type
+      , tgToEntries :
           {-
           A means of getting entries for this transaction (minimum 1)
           -}
-          List EntryGetter.Type
-      , tgCurrency :
-          {-
-          Currency against which entries in this transaction will be balanced
-          -}
-          EntryCurGetter
-      , tgAcnt :
-          {-
-          Account in which entries in this transaction will be balanced
-          -}
-          EntryAcntGetter
+          List ToEntryGetter.Type
       }
 
 let StatementParser_ =
@@ -1051,7 +1077,8 @@ in  { CurID
     , Field
     , FieldMap
     , Entry
-    , EntryGetter
+    , FromEntryGetter
+    , ToEntryGetter
     , EntryTextGetter
     , EntryCurGetter
     , EntryAcntGetter
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index ea29dbf..3533dd4 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -421,9 +421,13 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
+type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
 
-instance FromDhall EntryGetter
+type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID
+
+instance FromDhall ToEntryGetter
+
+instance FromDhall FromEntryGetter
 
 deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
 
@@ -440,10 +444,6 @@ data Tx s = Tx
   }
   deriving (Generic)
 
-type ExpTx = Tx EntryGetter
-
-instance FromDhall ExpTx
-
 data TxOpts re = TxOpts
   { toDate :: !T.Text
   , toAmount :: !T.Text
@@ -504,9 +504,10 @@ data FieldMatcher re
 deriving instance Show (FieldMatcher T.Text)
 
 data TxGetter = TxGetter
-  { tgCurrency :: !EntryCur
-  , tgAcnt :: !EntryAcnt
-  , tgEntries :: ![EntryGetter]
+  { tgFromAcnt :: !EntryAcnt
+  , tgFromCurrency :: !EntryCur
+  , tgFromEntries :: ![FromEntryGetter]
+  , tgToEntries :: ![ToEntryGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 3be6ee7..81c2636 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -129,6 +129,8 @@ accountSign EquityT = Credit
 
 type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
 
+type RawFromEntry = Entry AcntID Rational CurID TagID
+
 type BalEntry = Entry AcntID Rational CurID TagID
 
 type RawTx = Tx RawEntry
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index fcca4d1..9b55cf0 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -304,28 +304,41 @@ matches
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
-      convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
+      convert TxGetter {tgFromAcnt, tgFromCurrency, tgFromEntries, tgToEntries} =
+        MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r
 
-toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
-toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
-  combineError3 acntRes curRes ssRes $ \a c es ->
-    let fromEntry =
-          Entry
-            { eAcnt = a
-            , eCurrency = c
-            , eValue = Just trAmount
-            , eComment = ""
-            , eTags = [] -- TODO what goes here?
+toTx
+  :: EntryCur
+  -> EntryAcnt
+  -> [FromEntryGetter]
+  -> [ToEntryGetter]
+  -> TxRecord
+  -> InsertExceptT CurrencyM RawTx
+toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
+  combineError
+    (combineError acntRes curRes (,))
+    (combineError fromRes toRes (,))
+    $ \(a, c) (fs, ts) ->
+      let fromValue = trAmount - sum (fmap eValue fs)
+          fromEntry =
+            Entry
+              { eAcnt = a
+              , eCurrency = c
+              , eValue = Just fromValue
+              , eComment = ""
+              , eTags = [] -- TODO what goes here?
+              }
+       in Tx
+            { txDate = trDate
+            , txDescr = trDesc
+            , txEntries = fromEntry : fmap liftEntry fs ++ ts
             }
-     in Tx
-          { txDate = trDate
-          , txDescr = trDesc
-          , txEntries = fromEntry : es
-          }
   where
     acntRes = liftInner $ resolveAcnt r sa
     curRes = liftInner $ resolveCurrency r sc
-    ssRes = combineErrors $ fmap (resolveEntry r) toEntries
+    fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
+    toRes = combineErrors $ fmap (resolveToEntry r) toEntries
+    liftEntry e = e {eValue = Just $ eValue e}
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -351,8 +364,20 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
-resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry
+resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+  m <- ask
+  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+    v' <- roundPrecisionCur c m v
+    return $ s {eAcnt = a, eValue = v', eCurrency = c}
+  where
+    acntRes = resolveAcnt r eAcnt
+    curRes = resolveCurrency r eCurrency
+    valRes = resolveValue r eValue
+
+-- TODO wet code (kinda, not sure if it's worth combining with above)
+resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
+resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   m <- ask
   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
     v' <- mapM (roundPrecisionCur c m) v

From dcd260f6fd1f59bd2efa05f3abbbd4cb3a0587b1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 10 Jun 2023 21:38:13 -0400
Subject: [PATCH 02/59] FIX update types

---
 dhall/common.dhall | 26 +++++++++++++-------------
 1 file changed, 13 insertions(+), 13 deletions(-)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index b8c96d0..b20c534 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -4,10 +4,10 @@ let List/map =
 
 let T = ./Types.dhall
 
-let nullSplit =
+let nullEntry =
       \(a : T.EntryAcntGetter) ->
       \(c : T.EntryCurGetter) ->
-        T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
+        T.ToEntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
 
 let nullOpts = T.TxOpts::{=}
 
@@ -86,33 +86,33 @@ let mRngYMD =
       \(r : Natural) ->
         T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
 
-let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
+let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
 
 let partN =
       \(c : T.EntryCurGetter) ->
       \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
-      \(ss : List PartSplit) ->
-        let toSplit =
-              \(x : PartSplit) ->
-                    nullSplit (T.EntryAcntGetter.ConstT x._1) c
+      \(ss : List PartEntry) ->
+        let toEntry =
+              \(x : PartEntry) ->
+                    nullEntry (T.EntryAcntGetter.ConstT x._1) c
                 //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
                     , eComment = x._3
                     }
 
-        in    [ nullSplit a c // { eComment = comment } ]
-            # List/map PartSplit T.EntryGetter.Type toSplit ss
+        in    [ nullEntry a c // { eComment = comment } ]
+            # List/map PartEntry T.ToEntryGetter.Type toEntry ss
 
 let part1 =
       \(c : T.EntryCurGetter) ->
       \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
-        partN c a comment ([] : List PartSplit)
+        partN c a comment ([] : List PartEntry)
 
 let part1_ =
       \(c : T.EntryCurGetter) ->
       \(a : T.EntryAcntGetter) ->
-        partN c a "" ([] : List PartSplit)
+        partN c a "" ([] : List PartEntry)
 
 let addDay =
       \(x : T.GregorianM) ->
@@ -135,7 +135,7 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
 
 let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
 
-in      { nullSplit
+in      { nullEntry
         , nullMatch
         , nullVal
         , nullOpts
@@ -170,6 +170,6 @@ in      { nullSplit
         , mvDen
         , mvDenP
         , mvDenN
-        , PartSplit
+        , PartEntry
         }
     /\  T

From 45df1af53498e4d8d74ee00c4595cdf72188b08c Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 11 Jun 2023 12:27:57 -0400
Subject: [PATCH 03/59] ENH export account tree type

---
 dhall/Types.dhall     | 1 +
 lib/Internal/Utils.hs | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index ff279eb..0f02479 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -1095,6 +1095,7 @@ in  { CurID
     , BudgetCurrency
     , Exchange
     , TaggedAcnt
+    , AccountTree
     , Account
     , Placeholder
     , PretaxValue
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 9b55cf0..909021e 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -325,7 +325,7 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
               { eAcnt = a
               , eCurrency = c
               , eValue = Just fromValue
-              , eComment = ""
+              , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
        in Tx

From b2e4ee05e803f5d090242397e5b7040922e893f2 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 12 Jun 2023 00:27:34 -0400
Subject: [PATCH 04/59] WIP allow running balances to be used in history

---
 dhall/Types.dhall           | 36 ++++++++++----
 lib/Internal/Database.hs    |  2 +-
 lib/Internal/History.hs     | 94 +++++++++++++++++++++++++------------
 lib/Internal/Types/Dhall.hs | 14 ++++--
 lib/Internal/Types/Main.hs  | 13 +++--
 lib/Internal/Utils.hs       | 56 ++++++++++++----------
 6 files changed, 142 insertions(+), 73 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 0f02479..8dca7e3 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -396,15 +396,30 @@ let FieldMatcher_ =
 
 let FieldMatcher = FieldMatcher_ Text
 
-let EntryNumGetter =
+let FromEntryNumGetter =
     {-
     Means to get a numeric value from a statement row.
 
-    LookupN: lookup the value from a field
-    ConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    FLookupN: lookup the value from a field
+    FConstN: a constant value
+    FAmountN: the value of the 'Amount' column
+    FBalanceN: the amount required to make the target account reach a balance
     -}
-      < LookupN : Text | ConstN : Double | AmountN : Double >
+      < FLookupN : Text
+      | FConstN : Double
+      | FAmountN : Double
+      | FBalanceN : Double
+      >
+
+let ToEntryNumGetter =
+    {-
+    Means to get a numeric value from a statement row.
+
+    TLookupN: lookup the value from a field
+    TConstN: a constant value
+    TAmountN: the value of the 'Amount' column
+    -}
+      < TLookupN : Text | TConstN : Double | TAmountN : Double >
 
 let EntryTextGetter =
     {-
@@ -477,8 +492,8 @@ let FromEntryGetter =
     Means for getting an entry from a given row in a statement to apply to the
     credit side of the transaction.
     -}
-      { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
+      , default = { eValue = None FromEntryNumGetter, eComment = "" }
       }
 
 let ToEntryGetter =
@@ -487,8 +502,8 @@ let ToEntryGetter =
     debit side of the transaction.
     -}
       { Type =
-          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
+      , default = { eValue = None ToEntryNumGetter, eComment = "" }
       }
 
 let TxGetter =
@@ -1073,7 +1088,8 @@ in  { CurID
     , DateMatcher
     , FieldMatcher
     , FieldMatcher_
-    , EntryNumGetter
+    , FromEntryNumGetter
+    , ToEntryNumGetter
     , Field
     , FieldMap
     , Entry
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 0f429a1..22611ba 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -411,6 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
       s
         { eAcnt = aid
         , eCurrency = cid
-        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eValue = fromIntegral (sign2Int sign) * eValue
         , eTags = tags
         }
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 2b34f0f..4c6d630 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -1,8 +1,8 @@
 module Internal.History
   ( splitHistory
-  , insertHistTransfer
+  , readHistTransfer
   , readHistStmt
-  , insertHistStmt
+  , insertHistory
   )
 where
 
@@ -17,6 +17,7 @@ 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 qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
@@ -27,62 +28,70 @@ splitHistory = partitionEithers . fmap go
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-insertHistTransfer
+insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => HistTransfer
+  => [(CommitR, [RawTx])]
   -> m ()
-insertHistTransfer
+insertHistory hs = do
+  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
+  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
+    ck <- insert c
+    mapM_ (insertTx ck) ts
+
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey f = fmap go . NE.groupAllWith (f . fst)
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
+readHistTransfer
+  :: (MonadInsertError m, MonadFinance m)
+  => HistTransfer
+  -> m (Maybe (CommitR, [RawTx]))
+readHistTransfer
   m@Transfer
     { transFrom = from
     , transTo = to
     , transCurrency = u
     , transAmounts = amts
     } = do
-    whenHash CTManual m () $ \c -> do
+    whenHash_ CTManual m $ do
       bounds <- askDBState kmStatementInterval
       let precRes = lookupCurrencyPrec u
       let go Amount {amtWhen, amtValue, amtDesc} = do
             let dayRes = liftExcept $ expandDatePat bounds amtWhen
             (days, precision) <- combineError dayRes precRes (,)
             let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
-            keys <- combineErrors $ fmap tx days
-            mapM_ (insertTx c) keys
-      void $ combineErrors $ fmap go amts
+            return $ fmap tx days
+      concat <$> mapErrors go amts
 
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Maybe (CommitR, [KeyTx]))
+  -> m (Maybe (CommitR, [RawTx]))
 readHistStmt root i = whenHash_ CTImport i $ do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
-  liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
-
-insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
-insertHistStmt c ks = do
-  ck <- insert c
-  mapM_ (insertTx ck) ks
+  return $ filter (inDaySpan bounds . txDate) bs
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
 -- TODO tags here?
 txPair
-  :: (MonadInsertError m, MonadFinance m)
-  => Day
+  :: Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> m KeyTx
-txPair day from to cur val desc = resolveTx tx
+  -> RawTx
+txPair day from to cur val desc = tx
   where
     split a v =
       Entry
         { eAcnt = a
-        , eValue = v
+        , eValue = ConstD v
         , eComment = ""
         , eCurrency = cur
         , eTags = []
@@ -109,7 +118,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
@@ -155,11 +164,13 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
+-- TODO need to somehow balance temporally here (like I do in the budget for
+-- directives that "pay off" a balance)
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
@@ -303,12 +314,37 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> InsertExcept BalTx
-balanceTx t@Tx {txEntries = ss} = do
-  bs <- balanceEntries ss
-  return $ t {txEntries = bs}
+balanceTxs
+  :: (MonadInsertError m, MonadFinance m)
+  => [(CommitR, RawTx)]
+  -> m [(CommitR, KeyTx)]
+balanceTxs ts = do
+  bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
+  return $ zip cs bs
+  where
+    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
 
-balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
+balanceTxTargets
+  :: M.Map a Rational
+  -> Tx (Entry a (Deferred Rational) c t)
+  -> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t))
+balanceTxTargets = undefined
+
+balanceEntryTargets
+  :: M.Map a Rational
+  -> Entry a (Deferred Rational) c t
+  -> (M.Map a Rational, Entry a (Maybe Rational) c t)
+balanceEntryTargets = undefined
+
+balanceTx
+  :: (MonadInsertError m, MonadFinance m)
+  => Tx (Entry AcntID (Maybe Rational) CurID TagID)
+  -> m KeyTx
+balanceTx t@Tx {txEntries = ss} = do
+  bs <- liftExcept $ balanceEntries ss
+  resolveTx $ t {txEntries = bs}
+
+balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
 balanceEntries ss =
   fmap concat
     <$> mapM (uncurry bal)
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 3533dd4..f08a9ab 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -32,7 +32,8 @@ makeHaskellTypesWith
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
   , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
-  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
+  , MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
+  , MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
@@ -97,7 +98,8 @@ deriveProduct
   , "YMDMatcher"
   , "BudgetCurrency"
   , "Exchange"
-  , "EntryNumGetter"
+  , "FromEntryNumGetter"
+  , "ToEntryNumGetter"
   , "TemporalScope"
   , "SqlConfig"
   , "PretaxValue"
@@ -338,7 +340,9 @@ instance Ord DateMatcher where
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Hashable EntryNumGetter
+deriving instance Hashable FromEntryNumGetter
+
+deriving instance Hashable ToEntryNumGetter
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -421,9 +425,9 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
+type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
 
-type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID
+type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
 
 instance FromDhall ToEntryGetter
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 81c2636..e8ab791 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -59,8 +59,12 @@ data DBUpdates = DBUpdates
 
 type CurrencyM = Reader CurrencyMap
 
+type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
+
 type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
 
+type DeferredKeyTx = Tx DeferredKeyEntry
+
 type KeyTx = Tx KeyEntry
 
 type TreeR = Tree ([T.Text], AccountRId)
@@ -127,9 +131,12 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
+data Deferred a = ConstD a | Target a | Derive
+  deriving (Show, Functor, Foldable, Traversable)
 
-type RawFromEntry = Entry AcntID Rational CurID TagID
+type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
+
+-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 type BalEntry = Entry AcntID Rational CurID TagID
 
@@ -172,7 +179,7 @@ data InsertError
   | ParseError !T.Text
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
-  | BalanceError !BalanceType !CurID ![RawEntry]
+  | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
   | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 909021e..e69d609 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -319,26 +319,24 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
     (combineError acntRes curRes (,))
     (combineError fromRes toRes (,))
     $ \(a, c) (fs, ts) ->
-      let fromValue = trAmount - sum (fmap eValue fs)
-          fromEntry =
+      let fromEntry =
             Entry
               { eAcnt = a
               , eCurrency = c
-              , eValue = Just fromValue
+              , eValue = ConstD trAmount
               , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
        in Tx
             { txDate = trDate
             , txDescr = trDesc
-            , txEntries = fromEntry : fmap liftEntry fs ++ ts
+            , txEntries = fromEntry : fs ++ ts
             }
   where
     acntRes = liftInner $ resolveAcnt r sa
     curRes = liftInner $ resolveCurrency r sc
     fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
     toRes = combineErrors $ fmap (resolveToEntry r) toEntries
-    liftEntry e = e {eValue = Just $ eValue e}
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -364,20 +362,8 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry
+resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
 resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-  m <- ask
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-    v' <- roundPrecisionCur c m v
-    return $ s {eAcnt = a, eValue = v', eCurrency = c}
-  where
-    acntRes = resolveAcnt r eAcnt
-    curRes = resolveCurrency r eCurrency
-    valRes = resolveValue r eValue
-
--- TODO wet code (kinda, not sure if it's worth combining with above)
-resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
-resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   m <- ask
   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
     v' <- mapM (roundPrecisionCur c m) v
@@ -385,7 +371,19 @@ resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   where
     acntRes = resolveAcnt r eAcnt
     curRes = resolveCurrency r eCurrency
-    valRes = mapM (resolveValue r) eValue
+    valRes = resolveFromValue r eValue
+
+-- TODO wet code (kinda, not sure if it's worth combining with above)
+resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
+resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+  m <- ask
+  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+    v' <- mapM (roundPrecisionCur c m) v
+    return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
+  where
+    acntRes = resolveAcnt r eAcnt
+    curRes = resolveCurrency r eCurrency
+    valRes = mapM (resolveToValue r) eValue
 
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
@@ -470,11 +468,19 @@ mapErrorsIO f xs = do
 collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
 collectErrorsIO = mapErrorsIO id
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
-resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
-  (ConstN c) -> return c
-  AmountN m -> return $ (* m) $ fromRational trAmount
+resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
+resolveFromValue TxRecord {trOther, trAmount} s = case s of
+  (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (FConstN c) -> return $ ConstD c
+  FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
+  FBalanceN x -> return $ Target x
+
+-- TODO not DRY
+resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
+resolveToValue TxRecord {trOther, trAmount} s = case s of
+  (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+  (TConstN c) -> return c
+  TAmountN m -> return $ (* m) $ fromRational trAmount
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
@@ -750,7 +756,7 @@ showMatchOther (Val (Field f mv)) =
     , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
-showEntry :: RawEntry -> T.Text
+showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
 showEntry Entry {eAcnt, eValue, eComment} =
   keyVals
     [ ("account", eAcnt)

From 592c1550c0ab0e94799773a24b84ab98c46568ed Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 13 Jun 2023 20:12:23 -0400
Subject: [PATCH 05/59] FIX typo

---
 dhall/common.dhall | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index b20c534..275d926 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -96,7 +96,7 @@ let partN =
         let toEntry =
               \(x : PartEntry) ->
                     nullEntry (T.EntryAcntGetter.ConstT x._1) c
-                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
+                //  { eValue = Some (T.ToEntryNumGetter.TConstN x._2)
                     , eComment = x._3
                     }
 

From efffda378ae168ce5ba6fdf72435e72e7d914a60 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 13 Jun 2023 20:12:29 -0400
Subject: [PATCH 06/59] ADD calculations for running balances in statements

---
 app/Main.hs             | 12 +++----
 lib/Internal/Budget.hs  |  4 ---
 lib/Internal/History.hs | 79 ++++++++++++++++++++++++++---------------
 lib/Internal/Utils.hs   |  4 +++
 4 files changed, 61 insertions(+), 38 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 666c943..597a8c1 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -180,13 +180,13 @@ runSync c = do
 
     -- update the DB
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      let hTransRes = mapErrors insertHistTransfer hTs
-      let bgtRes = mapErrors insertBudget $ budget config
+      let runHist = do
+            ts <- catMaybes <$> mapErrors readHistTransfer hTs
+            insertHistory $ bSs ++ ts
+      let runBudget = mapErrors insertBudget $ budget config
       updateDBState updates -- TODO this will only work if foreign keys are deferred
-      res <- runExceptT $ do
-        mapM_ (uncurry insertHistStmt) bSs
-        combineError hTransRes bgtRes $ \_ _ -> ()
-      rerunnableIO $ fromEither res
+      res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
+      rerunnableIO $ fromEither res -- TODO why is this here?
   where
     root = takeDirectory c
     err (InsertException es) = do
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index ec92a72..1e0a3db 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -74,10 +74,6 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
     amtToMove bal BTPercent x = -(x / 100 * bal)
     amtToMove bal BTTarget x = x - bal
 
--- TODO this seems too general for this module
-mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
-mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
-
 insertBudgetTx
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => BalancedTransfer
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 4c6d630..3042569 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -1,8 +1,8 @@
 module Internal.History
-  ( splitHistory
+  ( readHistStmt
   , readHistTransfer
-  , readHistStmt
   , insertHistory
+  , splitHistory
   )
 where
 
@@ -22,26 +22,16 @@ import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 
-splitHistory :: [History] -> ([HistTransfer], [Statement])
-splitHistory = partitionEithers . fmap go
-  where
-    go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
-
-insertHistory
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [(CommitR, [RawTx])]
-  -> m ()
-insertHistory hs = do
-  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
-  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
-    ck <- insert c
-    mapM_ (insertTx ck) ts
-
-groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
-groupKey f = fmap go . NE.groupAllWith (f . fst)
-  where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+-- readHistory
+--   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
+--   => FilePath
+--   -> [History]
+--   -> m [(CommitR, [RawTx])]
+-- readHistory root hs = do
+--   let (ts, ss) = splitHistory hs
+--   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
+--   ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
+--   return $ ts' ++ ss'
 
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
@@ -64,6 +54,11 @@ readHistTransfer
             return $ fmap tx days
       concat <$> mapErrors go amts
 
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey f = fmap go . NE.groupAllWith (f . fst)
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
@@ -74,6 +69,22 @@ readHistStmt root i = whenHash_ CTImport i $ do
   bounds <- askDBState kmStatementInterval
   return $ filter (inDaySpan bounds . txDate) bs
 
+splitHistory :: [History] -> ([HistTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
+insertHistory
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => [(CommitR, [RawTx])]
+  -> m ()
+insertHistory hs = do
+  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
+  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
+    ck <- insert c
+    mapM_ (insertTx ck) ts
+
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
@@ -325,16 +336,28 @@ balanceTxs ts = do
     (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
 
 balanceTxTargets
-  :: M.Map a Rational
+  :: (Ord a, Ord c)
+  => M.Map (a, c) Rational
   -> Tx (Entry a (Deferred Rational) c t)
-  -> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t))
-balanceTxTargets = undefined
+  -> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
+balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
+  where
+    (bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
 
 balanceEntryTargets
-  :: M.Map a Rational
+  :: (Ord a, Ord c)
+  => M.Map (a, c) Rational
   -> Entry a (Deferred Rational) c t
-  -> (M.Map a Rational, Entry a (Maybe Rational) c t)
-balanceEntryTargets = undefined
+  -> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
+balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
+  where
+    key = (eAcnt, eCurrency)
+    curBal = M.findWithDefault 0 key bals
+    v = case eValue of
+      ConstD x -> Just x
+      Target x -> Just $ x - curBal
+      Derive -> Nothing
+    bals' = maybe bals (\y -> mapAdd_ key y bals) v
 
 balanceTx
   :: (MonadInsertError m, MonadFinance m)
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index e69d609..72ce337 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -55,6 +55,7 @@ module Internal.Utils
   , lookupCurrencyKey
   , lookupCurrencyPrec
   , lookupTag
+  , mapAdd_
   )
 where
 
@@ -855,6 +856,9 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 -- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
 -- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
+
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 

From 6926003c46666ed1c19c9980949be9cc6a6053ae Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 13 Jun 2023 20:32:12 -0400
Subject: [PATCH 07/59] ENH assault user's face with all errors at once

---
 lib/Internal/History.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 3042569..b1f05c3 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -116,9 +116,7 @@ txPair day from to cur val desc = tx
 
 resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
 resolveTx t@Tx {txEntries = ss} =
-  fmap (\kss -> t {txEntries = kss}) $
-    combineErrors $
-      fmap resolveEntry ss
+  fmap (\kss -> t {txEntries = kss}) $ combineErrors $ fmap resolveEntry ss
 
 insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
 insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
@@ -330,7 +328,7 @@ balanceTxs
   => [(CommitR, RawTx)]
   -> m [(CommitR, KeyTx)]
 balanceTxs ts = do
-  bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
+  bs <- mapErrors balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
   return $ zip cs bs
   where
     (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts

From ad0975aba74a144f5df23277225f65f38df2e88f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 16 Jun 2023 22:05:28 -0400
Subject: [PATCH 08/59] ENH use sane types to simplify tx balancing

---
 dhall/Types.dhall           | 119 ++++++++++-------
 lib/Internal/Database.hs    |  16 +--
 lib/Internal/History.hs     | 176 ++++++++++++++-----------
 lib/Internal/Types/Dhall.hs |  53 ++++----
 lib/Internal/Types/Main.hs  |  57 ++++++--
 lib/Internal/Utils.hs       | 254 +++++++++++++++++++++++-------------
 6 files changed, 411 insertions(+), 264 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 8dca7e3..f6f4b24 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -396,31 +396,21 @@ let FieldMatcher_ =
 
 let FieldMatcher = FieldMatcher_ Text
 
-let FromEntryNumGetter =
+let EntryNumGetter =
     {-
     Means to get a numeric value from a statement row.
 
-    FLookupN: lookup the value from a field
-    FConstN: a constant value
-    FAmountN: the value of the 'Amount' column
-    FBalanceN: the amount required to make the target account reach a balance
+    LookupN: lookup the value from a field
+    ConstN: a constant value
+    AmountN: the value of the 'Amount' column
+    BalanceN: the amount required to make the target account reach a balance
     -}
-      < FLookupN : Text
-      | FConstN : Double
-      | FAmountN : Double
-      | FBalanceN : Double
+      < LookupN : Text
+      | ConstN : Double
+      | AmountN : Double
+      | BalanceN : Double
       >
 
-let ToEntryNumGetter =
-    {-
-    Means to get a numeric value from a statement row.
-
-    TLookupN: lookup the value from a field
-    TConstN: a constant value
-    TAmountN: the value of the 'Amount' column
-    -}
-      < TLookupN : Text | TConstN : Double | TAmountN : Double >
-
 let EntryTextGetter =
     {-
     Means to get a textual value from a statement row.
@@ -458,7 +448,6 @@ let Entry =
     -}
       \(a : Type) ->
       \(v : Type) ->
-      \(c : Type) ->
       \(t : Type) ->
         { eAcnt :
             {-
@@ -470,11 +459,6 @@ let Entry =
             Pertains to value for this entry.
             -}
             v
-        , eCurrency :
-            {-
-            Pertains to value for this entry.
-            -}
-            c
         , eComment :
             {-
             A short description of this entry (if none, use a blank string)
@@ -487,31 +471,65 @@ let Entry =
             List t
         }
 
-let FromEntryGetter =
+let EntryGetter =
     {-
-    Means for getting an entry from a given row in a statement to apply to the
-    credit side of the transaction.
+    Means for getting an entry from a given row in a statement
     -}
-      { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
-      , default = { eValue = None FromEntryNumGetter, eComment = "" }
+      { Type = Entry EntryAcntGetter EntryNumGetter TagID
+      , default = { eValue = None EntryNumGetter, eComment = "" }
       }
 
-let ToEntryGetter =
+let TxSubGetter =
     {-
-    Means for getting an entry from a given row in a statement to apply to the
-    debit side of the transaction.
+    A means for transforming one row in a statement to a transaction
     -}
-      { Type =
-          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None ToEntryNumGetter, eComment = "" }
+      { tsgFromAcnt :
+          {-
+          -}
+          EntryAcntGetter
+      , tsgToAcnt :
+          {-
+          -}
+          EntryAcntGetter
+      , tsgValue :
+          {-
+          -}
+          EntryNumGetter
+      , tsgCurrency :
+          {-
+          -}
+          EntryCurGetter
+      , tsgFromEntries :
+          {-
+          -}
+          List EntryGetter.Type
+      , tsgToEntries :
+          {-
+          A means of getting entries for this transaction (minimum 1)
+          -}
+          List EntryGetter.Type
       }
 
 let TxGetter =
     {-
     A means for transforming one row in a statement to a transaction
 
-    Note that N-1 entries need to be specified to make a transaction, as the
-    Nth entry will be balanced with the others.
+    At least two entries must be made for any given transaction. Below these
+    correspond to the 'from' and 'to' accounts, which will share a single value
+    (whose positive is added to 'to' and negative is added to 'from' accounts)
+    given by the record (ie one row in a statement) denominated in the given
+    currency.
+
+    Optionally, both sides of the from/to flow of value can be split with other
+    accounts (given by 'tgFromEntries' and 'tgToEntries'). In either case, the
+    amount actually transferred between the 'from' and 'to' accounts above
+    will be the difference after considering these additional account entries.
+
+    Furthermore, additionally entries denominated in different currencies
+    may be specified via 'tgOtherEntries'. Each member in this list corresponds
+    to a different currency (and associated entries) governed by most of the
+    rules for this type regarding balancing and splitting value.
+
     -}
       { tgFromAcnt :
           {-
@@ -520,7 +538,14 @@ let TxGetter =
           entries are specified (see below).
           -}
           EntryAcntGetter
-      , tgFromCurrency :
+      , tgToAcnt :
+          {-
+          Account from which this transaction will be balanced. The value of
+          the transaction will be assigned to this account unless other from
+          entries are specified (see below).
+          -}
+          EntryAcntGetter
+      , tgCurrency :
           {-
           Currency to assign to the account/value denoted by 'tgFromAcnt'
           above.
@@ -538,12 +563,16 @@ let TxGetter =
           This is useful for situations where a particular transaction denotes
           values that come from multiple subaccounts.
           -}
-          List FromEntryGetter.Type
+          List EntryGetter.Type
       , tgToEntries :
           {-
-          A means of getting entries for this transaction (minimum 1)
+          A means of getting entries for this transaction
           -}
-          List ToEntryGetter.Type
+          List EntryGetter.Type
+      , tgOtherEntries :
+          {-
+          -}
+          List TxSubGetter
       }
 
 let StatementParser_ =
@@ -1088,13 +1117,11 @@ in  { CurID
     , DateMatcher
     , FieldMatcher
     , FieldMatcher_
-    , FromEntryNumGetter
-    , ToEntryNumGetter
+    , EntryNumGetter
     , Field
     , FieldMap
     , Entry
-    , FromEntryGetter
-    , ToEntryGetter
+    , EntryGetter
     , EntryTextGetter
     , EntryCurGetter
     , EntryAcntGetter
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 22611ba..3c64fea 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -11,7 +11,9 @@ module Internal.Database
   , whenHash
   , whenHash_
   , insertEntry
+  -- , insertEntrySet
   , resolveEntry
+  -- , resolveEntrySet
   )
 where
 
@@ -393,15 +395,15 @@ whenHash_ t o f = do
   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
 insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
-insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
-  k <- insert $ EntryR t eCurrency eAcnt eComment eValue
+insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do
+  k <- insert $ EntryR t feCurrency eAcnt eComment eValue
   mapM_ (insert_ . TagRelationR k) eTags
   return k
 
 resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
+resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
   let aRes = lookupAccountKey eAcnt
-  let cRes = lookupCurrencyKey eCurrency
+  let cRes = lookupCurrencyKey feCurrency
   let sRes = lookupAccountSign eAcnt
   let tagRes = combineErrors $ fmap lookupTag eTags
   -- TODO correct sign here?
@@ -409,8 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
   combineError (combineError3 aRes cRes sRes (,,)) tagRes $
     \(aid, cid, sign) tags ->
       s
-        { eAcnt = aid
-        , eCurrency = cid
-        , eValue = fromIntegral (sign2Int sign) * eValue
-        , eTags = tags
+        { feCurrency = cid
+        , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
         }
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index b1f05c3..8d90ae0 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -8,7 +8,8 @@ where
 
 import Control.Monad.Except
 import Data.Csv
-import Database.Persist.Monad
+import Data.Foldable
+import Database.Persist.Monad hiding (get)
 import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
@@ -18,6 +19,7 @@ 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
@@ -26,7 +28,7 @@ import qualified RIO.Vector as V
 --   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
 --   => FilePath
 --   -> [History]
---   -> m [(CommitR, [RawTx])]
+--   -> m [(CommitR, [DeferredTx])]
 -- readHistory root hs = do
 --   let (ts, ss) = splitHistory hs
 --   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
@@ -36,7 +38,7 @@ import qualified RIO.Vector as V
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => HistTransfer
-  -> m (Maybe (CommitR, [RawTx]))
+  -> m (Maybe (CommitR, [DeferredTx]))
 readHistTransfer
   m@Transfer
     { transFrom = from
@@ -63,11 +65,11 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Maybe (CommitR, [RawTx]))
+  -> m (Maybe (CommitR, [DeferredTx]))
 readHistStmt root i = whenHash_ CTImport i $ do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
-  return $ filter (inDaySpan bounds . txDate) bs
+  return $ filter (inDaySpan bounds . dtxDate) bs
 
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
@@ -77,7 +79,7 @@ splitHistory = partitionEithers . fmap go
 
 insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [(CommitR, [RawTx])]
+  => [(CommitR, [DeferredTx])]
   -> m ()
 insertHistory hs = do
   bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
@@ -96,30 +98,37 @@ txPair
   -> CurID
   -> Rational
   -> T.Text
-  -> RawTx
-txPair day from to cur val desc = tx
+  -> DeferredTx
+txPair day from to cur val desc =
+  Tx
+    { dtxDescr = desc
+    , dtxDate = day
+    , dtxEntries =
+        [ EntrySet
+            { desTotalValue = val
+            , desCurrency = cur
+            , desFromEntry0 = entry from
+            , desToEntryBal = entry to
+            , desFromEntries = []
+            , desToEntries = []
+            }
+        ]
+    }
   where
-    split a v =
+    entry a =
       Entry
         { eAcnt = a
-        , eValue = ConstD v
+        , eValue = ()
         , eComment = ""
-        , eCurrency = cur
         , eTags = []
         }
-    tx =
-      Tx
-        { txDescr = desc
-        , txDate = day
-        , txEntries = [split from (-val), split to val]
-        }
 
 resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
-resolveTx t@Tx {txEntries = ss} =
-  fmap (\kss -> t {txEntries = kss}) $ combineErrors $ fmap resolveEntry ss
+resolveTx t@Tx {dtxEntries = ss} =
+  (\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
 
 insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
-insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
+insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
   k <- insert $ TransactionR c d e
   mapM_ (insertEntry k) ss
 
@@ -127,7 +136,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
@@ -175,7 +184,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
 
 -- TODO need to somehow balance temporally here (like I do in the budget for
 -- directives that "pay off" a balance)
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
@@ -236,7 +245,7 @@ zipperSlice f x = go
 zipperMatch
   :: Unzipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -252,7 +261,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
 zipperMatch'
   :: Zipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -269,7 +278,7 @@ matchDec m = case spTimes m of
   Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -279,13 +288,13 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
   return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -306,7 +315,7 @@ matchDates ms = go ([], [], initZipper ms)
           go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -323,63 +332,74 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
+-- TDOO should use a better type here to squish down all the entry sets
+-- which at this point in the chain should not be necessary
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [(CommitR, RawTx)]
+  => [(CommitR, DeferredTx)]
   -> m [(CommitR, KeyTx)]
 balanceTxs ts = do
-  bs <- mapErrors balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
-  return $ zip cs bs
+  keyts <- mapErrors resolveTx balTs
+  return $ zip cs keyts
   where
-    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
+    (cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
+    go bals t@Tx {dtxEntries} =
+      second (\es -> t {dtxEntries = concat es}) $
+        L.mapAccumL balanceEntrySet bals dtxEntries
+    balTs = snd $ L.mapAccumL go M.empty ts'
 
-balanceTxTargets
-  :: (Ord a, Ord c)
-  => M.Map (a, c) Rational
-  -> Tx (Entry a (Deferred Rational) c t)
-  -> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
-balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
-  where
-    (bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
+type EntryBals = M.Map (AcntID, CurID) Rational
 
-balanceEntryTargets
-  :: (Ord a, Ord c)
-  => M.Map (a, c) Rational
-  -> Entry a (Deferred Rational) c t
-  -> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
-balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
+-- TODO might be faster to also do all the key stuff here since currency
+-- will be looked up for every entry rather then the entire entry set
+balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
+balanceEntrySet
+  bals
+  EntrySet
+    { desFromEntry0
+    , desFromEntries
+    , desToEntryBal
+    , desToEntries
+    , desCurrency
+    , desTotalValue
+    } = flipTup $ runState doBalAll bals
+    where
+      flipTup (a, b) = (b, a)
+      doEntries es tot e0 = do
+        es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
+        let val0 = tot - entrySum es'
+        modify $ mapAdd_ (eAcnt e0, desCurrency) val0
+        return $ e0 {eValue = val0} : es'
+      doBalAll = do
+        fes <- doEntries desFromEntries desTotalValue desFromEntry0
+        tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
+        return $ toFull <$> fes ++ tes
+      toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
+
+entrySum :: Num v => [Entry a v t] -> v
+entrySum = sum . fmap eValue
+
+balanceEntry
+  :: CurID
+  -> EntryBals
+  -> Entry AcntID (Deferred Rational) TagID
+  -> (EntryBals, Entry AcntID Rational TagID)
+balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt}
+  | toBal = (bals, e {eValue = v})
+  | otherwise = (bals', e {eValue = newVal})
   where
-    key = (eAcnt, eCurrency)
+    key = (eAcnt, curID)
     curBal = M.findWithDefault 0 key bals
-    v = case eValue of
-      ConstD x -> Just x
-      Target x -> Just $ x - curBal
-      Derive -> Nothing
-    bals' = maybe bals (\y -> mapAdd_ key y bals) v
+    newVal = v - curBal
+    bals' = mapAdd_ key newVal bals
 
-balanceTx
-  :: (MonadInsertError m, MonadFinance m)
-  => Tx (Entry AcntID (Maybe Rational) CurID TagID)
-  -> m KeyTx
-balanceTx t@Tx {txEntries = ss} = do
-  bs <- liftExcept $ balanceEntries ss
-  resolveTx $ t {txEntries = bs}
-
-balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
-balanceEntries ss =
-  fmap concat
-    <$> mapM (uncurry bal)
-    $ groupByKey
-    $ fmap (\s -> (eCurrency s, s)) ss
-  where
-    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
-    haeValue s = Left s
-    bal cur rss
-      | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
-      | otherwise = case partitionEithers $ fmap haeValue rss of
-          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
-          ([], val) -> return val
-          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
-
-groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
-groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
+-- -- 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
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index f08a9ab..49b6fe1 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -19,7 +19,7 @@ import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.Text as T
-import RIO.Time
+-- import RIO.Time
 import Text.Regex.TDFA
 
 makeHaskellTypesWith
@@ -32,8 +32,7 @@ makeHaskellTypesWith
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
   , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
-  , MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
-  , MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
+  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
@@ -98,8 +97,7 @@ deriveProduct
   , "YMDMatcher"
   , "BudgetCurrency"
   , "Exchange"
-  , "FromEntryNumGetter"
-  , "ToEntryNumGetter"
+  , "EntryNumGetter"
   , "TemporalScope"
   , "SqlConfig"
   , "PretaxValue"
@@ -340,9 +338,7 @@ instance Ord DateMatcher where
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Hashable FromEntryNumGetter
-
-deriving instance Hashable ToEntryNumGetter
+deriving instance Hashable EntryNumGetter
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -425,28 +421,17 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
+type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
 
-type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
+instance FromDhall EntryGetter
 
-instance FromDhall ToEntryGetter
+deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
 
-instance FromDhall FromEntryGetter
+deriving instance Generic (Entry a v t)
 
-deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
+deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
 
-deriving instance Generic (Entry a v c t)
-
-deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
-
-deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
-
-data Tx s = Tx
-  { txDescr :: !T.Text
-  , txDate :: !Day
-  , txEntries :: ![s]
-  }
-  deriving (Generic)
+deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
 
 data TxOpts re = TxOpts
   { toDate :: !T.Text
@@ -507,11 +492,23 @@ data FieldMatcher re
 
 deriving instance Show (FieldMatcher T.Text)
 
+data TxSubGetter = TxSubGetter
+  { tsgFromAcnt :: !EntryAcnt
+  , tsgToAcnt :: !EntryAcnt
+  , tsgValue :: !EntryNumGetter
+  , tsgCurrency :: !EntryCur
+  , tsgFromEntries :: ![EntryGetter]
+  , tsgToEntries :: ![EntryGetter]
+  }
+  deriving (Eq, Generic, Hashable, Show, FromDhall)
+
 data TxGetter = TxGetter
   { tgFromAcnt :: !EntryAcnt
-  , tgFromCurrency :: !EntryCur
-  , tgFromEntries :: ![FromEntryGetter]
-  , tgToEntries :: ![ToEntryGetter]
+  , tgToAcnt :: !EntryAcnt
+  , tgCurrency :: !EntryCur
+  , tgFromEntries :: ![EntryGetter]
+  , tgToEntries :: ![EntryGetter]
+  , tgOtherEntries :: ![TxSubGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index e8ab791..e4be06e 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -59,13 +59,20 @@ data DBUpdates = DBUpdates
 
 type CurrencyM = Reader CurrencyMap
 
-type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
+-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
 
-type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
+data FullEntry a c t = FullEntry
+  { feCurrency :: !c
+  , feEntry :: !(Entry a Rational t)
+  }
 
-type DeferredKeyTx = Tx DeferredKeyEntry
+type KeyEntry = FullEntry AccountRId CurrencyRId TagRId
 
-type KeyTx = Tx KeyEntry
+type BalEntry = FullEntry AcntID CurID TagID
+
+-- type DeferredKeyTx = Tx DeferredKeyEntry
+
+-- type KeyTx = Tx KeyEntry
 
 type TreeR = Tree ([T.Text], AccountRId)
 
@@ -131,18 +138,46 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-data Deferred a = ConstD a | Target a | Derive
+data EntrySet a c t v = EntrySet
+  { desTotalValue :: !Rational
+  , desCurrency :: !c
+  , desFromEntry0 :: !(Entry a () t)
+  , desFromEntries :: ![Entry a v t]
+  , desToEntries :: ![Entry a v t]
+  , desToEntryBal :: !(Entry a () t)
+  }
+
+data Tx e = Tx
+  { dtxDescr :: !T.Text
+  , dtxDate :: !Day
+  , dtxEntries :: !e
+  }
+  deriving (Generic)
+
+type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
+
+type BalEntrySet = EntrySet AcntID CurID TagID Rational
+
+type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
+
+type DeferredTx = Tx [DeferredEntrySet]
+
+type BalTx = Tx [BalEntry]
+
+type KeyTx = Tx [KeyEntry]
+
+data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
-type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
+-- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
-type BalEntry = Entry AcntID Rational CurID TagID
+-- type BalEntry = Entry AcntID Rational CurID TagID
 
-type RawTx = Tx RawEntry
+-- type RawTx = Tx RawEntry
 
-type BalTx = Tx BalEntry
+-- type BalTx = Tx BalEntry
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 
@@ -179,8 +214,8 @@ data InsertError
   | ParseError !T.Text
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
-  | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
-  | IncomeError !Day !T.Text !Rational
+  | -- | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
+    IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 72ce337..bb8090c 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -290,7 +290,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
+matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx)
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -305,39 +305,108 @@ matches
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
-      convert TxGetter {tgFromAcnt, tgFromCurrency, tgFromEntries, tgToEntries} =
-        MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r
+      convert tg = MatchPass <$> toTx tg r
 
+toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
 toTx
-  :: EntryCur
-  -> EntryAcnt
-  -> [FromEntryGetter]
-  -> [ToEntryGetter]
-  -> TxRecord
-  -> InsertExceptT CurrencyM RawTx
-toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
-  combineError
-    (combineError acntRes curRes (,))
-    (combineError fromRes toRes (,))
-    $ \(a, c) (fs, ts) ->
+  TxGetter {tgFromAcnt, tgToAcnt, tgCurrency, tgFromEntries, tgToEntries, tgOtherEntries}
+  r@TxRecord {trAmount, trDate, trDesc} = do
+    combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> do
       let fromEntry =
             Entry
-              { eAcnt = a
-              , eCurrency = c
-              , eValue = ConstD trAmount
+              { eAcnt = fa
+              , eValue = ()
               , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
+          toEntry =
+            Entry
+              { eAcnt = ta
+              , eValue = ()
+              , eComment = ""
+              , eTags = []
+              }
        in Tx
-            { txDate = trDate
-            , txDescr = trDesc
-            , txEntries = fromEntry : fs ++ ts
+            { dtxDate = trDate
+            , dtxDescr = trDesc
+            , dtxEntries =
+                EntrySet
+                  { desTotalValue = trAmount
+                  , desCurrency = cur
+                  , desFromEntry0 = fromEntry
+                  , desFromEntries = fe
+                  , desToEntries = te
+                  , desToEntryBal = toEntry
+                  }
+                  : ss
             }
-  where
-    acntRes = liftInner $ resolveAcnt r sa
-    curRes = liftInner $ resolveCurrency r sc
-    fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
-    toRes = combineErrors $ fmap (resolveToEntry r) toEntries
+    where
+      resolveAcnt_ = liftInner . resolveAcnt r
+      acntRes =
+        combineError
+          (resolveAcnt_ tgFromAcnt)
+          (resolveAcnt_ tgToAcnt)
+          (,)
+      curRes = do
+        cur <- liftInner $ resolveCurrency r tgCurrency
+        let feRes = mapErrors (resolveEntry cur r) tgFromEntries
+        let teRes = mapErrors (resolveEntry cur r) tgToEntries
+        combineError feRes teRes (cur,,)
+      subRes = mapErrors (resolveSubGetter r) tgOtherEntries
+
+resolveSubGetter
+  :: TxRecord
+  -> TxSubGetter
+  -> InsertExceptT CurrencyM DeferredEntrySet
+resolveSubGetter
+  r
+  TxSubGetter
+    { tsgFromAcnt
+    , tsgToAcnt
+    , tsgValue
+    , tsgCurrency
+    , tsgFromEntries
+    , tsgToEntries
+    } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
+    do
+      m <- ask
+      -- TODO laaaaame...
+      (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
+      let fromEntry =
+            Entry
+              { eAcnt = fa
+              , eValue = ()
+              , eComment = "" -- TODO actually fill this in
+              , eTags = [] -- TODO what goes here?
+              }
+      let toEntry =
+            Entry
+              { eAcnt = ta
+              , eValue = ()
+              , eComment = ""
+              , eTags = []
+              }
+      return
+        EntrySet
+          { desTotalValue = val
+          , desCurrency = cur
+          , desFromEntry0 = fromEntry
+          , desFromEntries = fe
+          , desToEntries = te
+          , desToEntryBal = toEntry
+          }
+    where
+      resolveAcnt_ = liftInner . resolveAcnt r
+      acntRes =
+        combineError
+          (resolveAcnt_ tsgFromAcnt)
+          (resolveAcnt_ tsgToAcnt)
+          (,)
+      curRes = do
+        cur <- liftInner $ resolveCurrency r tsgCurrency
+        let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
+        let teRes = mapErrors (resolveEntry cur r) tsgToEntries
+        combineError feRes teRes (cur,,)
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -363,28 +432,34 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
-resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+-- TODO this should be more general?
+resolveEntry
+  :: CurID
+  -> TxRecord
+  -> EntryGetter
+  -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
+resolveEntry cur r s@Entry {eAcnt, eValue} = do
   m <- ask
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-    v' <- mapM (roundPrecisionCur c m) v
-    return $ s {eAcnt = a, eValue = v', eCurrency = c}
+  liftInner $ combineErrorM acntRes valRes $ \a v -> do
+    v' <- mapM (roundPrecisionCur cur m) v
+    return $ s {eAcnt = a, eValue = v'}
   where
     acntRes = resolveAcnt r eAcnt
-    curRes = resolveCurrency r eCurrency
-    valRes = resolveFromValue r eValue
+    valRes = resolveValue r eValue
 
--- TODO wet code (kinda, not sure if it's worth combining with above)
-resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
-resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-  m <- ask
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-    v' <- mapM (roundPrecisionCur c m) v
-    return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
-  where
-    acntRes = resolveAcnt r eAcnt
-    curRes = resolveCurrency r eCurrency
-    valRes = mapM (resolveToValue r) eValue
+-- curRes = resolveCurrency r eCurrency
+
+-- -- TODO wet code (kinda, not sure if it's worth combining with above)
+-- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
+-- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+--   m <- ask
+--   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+--     v' <- mapM (roundPrecisionCur c m) v
+--     return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
+--   where
+--     acntRes = resolveAcnt r eAcnt
+--     curRes = resolveCurrency r eCurrency
+--     valRes = mapM (resolveToValue r) eValue
 
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
@@ -428,17 +503,28 @@ combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -
 combineErrorM3 a b c f = do
   combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
 
-combineErrors :: MonadError InsertException m => [m a] -> m [a]
+mapErrors
+  :: (Traversable t, MonadError InsertException m)
+  => (a -> m b)
+  -> t a
+  -> m (t b)
+-- First, record number of each action. Then try each action. On first failure,
+-- note it's position in the sequence, skip ahead to the untried actions,
+-- collect failures and add to the first failure.
+mapErrors f xs = mapM go $ enumTraversable xs
+  where
+    go (n, x) = catchError (f x) $ \e -> do
+      es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
+      throwError $ foldr (<>) e es
+    err x = catchError (Nothing <$ x) (pure . Just)
+
+combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a)
 combineErrors = mapErrors id
 
-mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
-mapErrors f xs = do
-  ys <- mapM (go . f) xs
-  case partitionEithers ys of
-    ([], zs) -> return zs
-    (e : es, _) -> throwError $ foldr (<>) e es
+enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
+enumTraversable = snd . L.mapAccumL go 0
   where
-    go x = catchError (Right <$> x) (pure . Left)
+    go n x = (n + 1, (n, x))
 
 combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
 combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
@@ -457,31 +543,30 @@ combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d)
 combineErrorIOM3 a b c f =
   combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
 
-mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
-mapErrorsIO f xs = do
-  ys <- mapM (go . f) xs
-  case partitionEithers ys of
-    ([], zs) -> return zs
-    (es, _) -> throwIO $ InsertException $ concat es
+mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
+mapErrorsIO f xs = mapM go $ enumTraversable xs
   where
-    go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
+    go (n, x) = catch (f x) $ \(InsertException e) -> do
+      es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
+      throwIO $ InsertException $ foldr (<>) e es
+    err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
 
-collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
+collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
-resolveFromValue TxRecord {trOther, trAmount} s = case s of
-  (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (FConstN c) -> return $ ConstD c
-  FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
-  FBalanceN x -> return $ Target x
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
+resolveValue TxRecord {trOther, trAmount} s = case s of
+  (LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (ConstN c) -> return $ Deferred False c
+  AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
+  BalanceN x -> return $ Deferred True x
 
--- TODO not DRY
-resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
-resolveToValue TxRecord {trOther, trAmount} s = case s of
-  (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
-  (TConstN c) -> return c
-  TAmountN m -> return $ (* m) $ fromRational trAmount
+-- -- TODO not DRY
+-- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
+-- resolveToValue TxRecord {trOther, trAmount} s = case s of
+--   (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+--   (TConstN c) -> return c
+--   TAmountN m -> return $ (* m) $ fromRational trAmount
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
@@ -656,20 +741,6 @@ showError other = case other of
         , singleQuote $ showT next
         ]
     ]
-  (BalanceError t cur rss) ->
-    [ T.unwords
-        [ msg
-        , "for currency"
-        , singleQuote cur
-        , "and for entries"
-        , entries
-        ]
-    ]
-    where
-      msg = case t of
-        TooFewEntries -> "Need at least two entries to balance"
-        NotOneBlank -> "Exactly one entries must be blank"
-      entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
 
 showGregorian_ :: Gregorian -> T.Text
 showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
@@ -757,14 +828,6 @@ showMatchOther (Val (Field f mv)) =
     , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
-showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
-showEntry Entry {eAcnt, eValue, eComment} =
-  keyVals
-    [ ("account", eAcnt)
-    , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
-    , ("comment", doubleQuote eComment)
-    ]
-
 singleQuote :: T.Text -> T.Text
 singleQuote t = T.concat ["'", t, "'"]
 
@@ -856,6 +919,11 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 -- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
 -- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 
+-- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+-- groupKey f = fmap go . NE.groupAllWith (f . fst)
+--   where
+--     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
 mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 

From 4c0b192b9c50b66273a8394604f27bf0dbdb6cde Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 16 Jun 2023 22:06:48 -0400
Subject: [PATCH 09/59] FIX typo (clean compile)

---
 lib/Internal/Budget.hs | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 1e0a3db..ad46f74 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -112,12 +112,15 @@ entryPair from to cur val = case cur of
       combineError s1 s2 (,)
     entry c TaggedAcnt {taAcnt, taTags} v =
       resolveEntry $
-        Entry
-          { eAcnt = taAcnt
-          , eValue = v
-          , eComment = ""
-          , eCurrency = c
-          , eTags = taTags
+        FullEntry
+          { feCurrency = c
+          , feEntry =
+              Entry
+                { eAcnt = taAcnt
+                , eValue = v
+                , eComment = ""
+                , eTags = taTags
+                }
           }
 
 sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)

From a144b9fa3cfbeed97f0bc1fb789f033db766c2fe Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 16 Jun 2023 23:41:01 -0400
Subject: [PATCH 10/59] ENH update dhall interface

---
 dhall/Types.dhall  |  2 +-
 dhall/common.dhall | 31 +++++++------------------------
 2 files changed, 8 insertions(+), 25 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index f6f4b24..f8e4793 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -476,7 +476,7 @@ let EntryGetter =
     Means for getting an entry from a given row in a statement
     -}
       { Type = Entry EntryAcntGetter EntryNumGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      , default = { eComment = "", eTags = [] : List TagID }
       }
 
 let TxSubGetter =
diff --git a/dhall/common.dhall b/dhall/common.dhall
index 275d926..dd888bf 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -6,8 +6,8 @@ let T = ./Types.dhall
 
 let nullEntry =
       \(a : T.EntryAcntGetter) ->
-      \(c : T.EntryCurGetter) ->
-        T.ToEntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
+      \(v : T.EntryNumGetter) ->
+        T.EntryGetter::{ eAcnt = a, eValue = v }
 
 let nullOpts = T.TxOpts::{=}
 
@@ -89,30 +89,15 @@ let mRngYMD =
 let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
 
 let partN =
-      \(c : T.EntryCurGetter) ->
-      \(a : T.EntryAcntGetter) ->
-      \(comment : Text) ->
       \(ss : List PartEntry) ->
         let toEntry =
               \(x : PartEntry) ->
-                    nullEntry (T.EntryAcntGetter.ConstT x._1) c
-                //  { eValue = Some (T.ToEntryNumGetter.TConstN x._2)
-                    , eComment = x._3
-                    }
+                    nullEntry
+                      (T.EntryAcntGetter.ConstT x._1)
+                      (T.EntryNumGetter.ConstN x._2)
+                //  { eComment = x._3 }
 
-        in    [ nullEntry a c // { eComment = comment } ]
-            # List/map PartEntry T.ToEntryGetter.Type toEntry ss
-
-let part1 =
-      \(c : T.EntryCurGetter) ->
-      \(a : T.EntryAcntGetter) ->
-      \(comment : Text) ->
-        partN c a comment ([] : List PartEntry)
-
-let part1_ =
-      \(c : T.EntryCurGetter) ->
-      \(a : T.EntryAcntGetter) ->
-        partN c a "" ([] : List PartEntry)
+        in  List/map PartEntry T.EntryGetter.Type toEntry ss
 
 let addDay =
       \(x : T.GregorianM) ->
@@ -157,8 +142,6 @@ in      { nullEntry
         , greg
         , gregM
         , partN
-        , part1
-        , part1_
         , addDay
         , comma = 44
         , tab = 9

From 5858e2f8ce01c14dcee8cffed83b3424242b150a Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 16 Jun 2023 23:46:09 -0400
Subject: [PATCH 11/59] FIX typo

---
 dhall/Types.dhall | 1 +
 1 file changed, 1 insertion(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index f8e4793..8294282 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -1150,6 +1150,7 @@ in  { CurID
     , BudgetTransferValue
     , BudgetTransferType
     , TxGetter
+    , TxSubGetter
     , HistTransfer
     , SingleAllocation
     , MultiAllocation

From c18750d600bf939e051b882f610b0a5030a8caae Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 17 Jun 2023 00:16:01 -0400
Subject: [PATCH 12/59] ADD comment and tags to txgetter

---
 dhall/Types.dhall           | 142 +++++++++++++++++++-----------------
 dhall/common.dhall          |   6 +-
 lib/Internal/Types/Dhall.hs |   4 +
 lib/Internal/Utils.hs       |  56 +++++++-------
 4 files changed, 109 insertions(+), 99 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 8294282..c9c31c8 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -483,31 +483,24 @@ let TxSubGetter =
     {-
     A means for transforming one row in a statement to a transaction
     -}
-      { tsgFromAcnt :
-          {-
-          -}
-          EntryAcntGetter
-      , tsgToAcnt :
-          {-
-          -}
-          EntryAcntGetter
-      , tsgValue :
-          {-
-          -}
-          EntryNumGetter
-      , tsgCurrency :
-          {-
-          -}
-          EntryCurGetter
-      , tsgFromEntries :
-          {-
-          -}
-          List EntryGetter.Type
-      , tsgToEntries :
-          {-
-          A means of getting entries for this transaction (minimum 1)
-          -}
-          List EntryGetter.Type
+      { Type =
+          { tsgFromAcnt : EntryAcntGetter
+          , tsgToAcnt : EntryAcntGetter
+          , tsgValue : EntryNumGetter
+          , tsgCurrency : EntryCurGetter
+          , tsgFromEntries : List EntryGetter.Type
+          , tsgFromComment : Text
+          , tsgToComment : Text
+          , tsgFromTags : List TagID
+          , tsgToTags : List TagID
+          , tsgToEntries : List EntryGetter.Type
+          }
+      , default =
+        { tsgFromTags = [] : List TagID
+        , tsgToTags = [] : List TagID
+        , tsgFromComment = ""
+        , tsgToComment = ""
+        }
       }
 
 let TxGetter =
@@ -531,48 +524,61 @@ let TxGetter =
     rules for this type regarding balancing and splitting value.
 
     -}
-      { tgFromAcnt :
-          {-
-          Account from which this transaction will be balanced. The value of
-          the transaction will be assigned to this account unless other from
-          entries are specified (see below).
-          -}
-          EntryAcntGetter
-      , tgToAcnt :
-          {-
-          Account from which this transaction will be balanced. The value of
-          the transaction will be assigned to this account unless other from
-          entries are specified (see below).
-          -}
-          EntryAcntGetter
-      , tgCurrency :
-          {-
-          Currency to assign to the account/value denoted by 'tgFromAcnt'
-          above.
-          -}
-          EntryCurGetter
-      , tgFromEntries :
-          {-
-          Means of getting additional entries from which this transaction will
-          be balanced (minimum 0). If this list is empty, the total value of the
-          transaction will be assigned to the value defined by 'tgFromAcnt'.
-          Otherwise, the entries specified here will be added to the credit side
-          of this transaction, and their sum value will be subtracted from the
-          total value of the transaction and assigned to 'tgFromAcnt'.
+      { Type =
+          { tgFromAcnt :
+              {-
+              Account from which this transaction will be balanced. The value of
+              the transaction will be assigned to this account unless other from
+              entries are specified (see below).
+              -}
+              EntryAcntGetter
+          , tgToAcnt :
+              {-
+              Account from which this transaction will be balanced. The value of
+              the transaction will be assigned to this account unless other from
+              entries are specified (see below).
+              -}
+              EntryAcntGetter
+          , tgFromComment : Text
+          , tgToComment : Text
+          , tgFromTags : List TagID
+          , tgToTags : List TagID
+          , tgCurrency :
+              {-
+              Currency to assign to the account/value denoted by 'tgFromAcnt'
+              above.
+              -}
+              EntryCurGetter
+          , tgFromEntries :
+              {-
+              Means of getting additional entries from which this transaction will
+              be balanced (minimum 0). If this list is empty, the total value of the
+              transaction will be assigned to the value defined by 'tgFromAcnt'.
+              Otherwise, the entries specified here will be added to the credit side
+              of this transaction, and their sum value will be subtracted from the
+              total value of the transaction and assigned to 'tgFromAcnt'.
 
-          This is useful for situations where a particular transaction denotes
-          values that come from multiple subaccounts.
-          -}
-          List EntryGetter.Type
-      , tgToEntries :
-          {-
-          A means of getting entries for this transaction
-          -}
-          List EntryGetter.Type
-      , tgOtherEntries :
-          {-
-          -}
-          List TxSubGetter
+              This is useful for situations where a particular transaction denotes
+              values that come from multiple subaccounts.
+              -}
+              List EntryGetter.Type
+          , tgToEntries :
+              {-
+              A means of getting entries for this transaction
+              -}
+              List EntryGetter.Type
+          , tgOtherEntries :
+              {-
+              -}
+              List TxSubGetter.Type
+          }
+      , default =
+        { tgOtherEntries = [] : List TxSubGetter.Type
+        , tgFromTags = [] : List TagID
+        , tgToTags = [] : List TagID
+        , tgFromComment = ""
+        , tgToComment = ""
+        }
       }
 
 let StatementParser_ =
@@ -612,7 +618,7 @@ let StatementParser_ =
                 a transaction. If none, don't make a transaction (eg 'skip'
                 this row in the statement).
                 -}
-                Optional TxGetter
+                Optional TxGetter.Type
             , spTimes :
                 {-
                 Match at most this many rows; if none there is no limit
@@ -629,7 +635,7 @@ let StatementParser_ =
           , spVal = ValMatcher::{=}
           , spDesc = None Text
           , spOther = [] : List (FieldMatcher_ re)
-          , spTx = None TxGetter
+          , spTx = None TxGetter.Type
           , spTimes = None Natural
           , spPriority = +0
           }
diff --git a/dhall/common.dhall b/dhall/common.dhall
index dd888bf..0f2a6e2 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -36,12 +36,14 @@ let cron1 =
 
 let matchInf_ = nullMatch
 
-let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
+let matchInf = \(x : T.TxGetter.Type) -> nullMatch // { spTx = Some x }
 
 let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
 
 let matchN =
-      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
+      \(n : Natural) ->
+      \(x : T.TxGetter.Type) ->
+        matchInf x // { spTimes = Some n }
 
 let match1_ = matchN_ 1
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 49b6fe1..9988d6d 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -505,6 +505,10 @@ data TxSubGetter = TxSubGetter
 data TxGetter = TxGetter
   { tgFromAcnt :: !EntryAcnt
   , tgToAcnt :: !EntryAcnt
+  , tgFromComment :: !T.Text
+  , tgToComment :: !T.Text
+  , tgFromTags :: ![TagID]
+  , tgToTags :: ![TagID]
   , tgCurrency :: !EntryCur
   , tgFromEntries :: ![EntryGetter]
   , tgToEntries :: ![EntryGetter]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index bb8090c..3bebb16 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -309,37 +309,34 @@ matches
 
 toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
 toTx
-  TxGetter {tgFromAcnt, tgToAcnt, tgCurrency, tgFromEntries, tgToEntries, tgOtherEntries}
+  TxGetter
+    { tgFromAcnt
+    , tgToAcnt
+    , tgFromComment
+    , tgToComment
+    , tgFromTags
+    , tgToTags
+    , tgCurrency
+    , tgFromEntries
+    , tgToEntries
+    , tgOtherEntries
+    }
   r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> do
-      let fromEntry =
-            Entry
-              { eAcnt = fa
-              , eValue = ()
-              , eComment = "" -- TODO actually fill this in
-              , eTags = [] -- TODO what goes here?
+    combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss ->
+      Tx
+        { dtxDate = trDate
+        , dtxDescr = trDesc
+        , dtxEntries =
+            EntrySet
+              { desTotalValue = trAmount
+              , desCurrency = cur
+              , desFromEntry0 = entry0 fa tgFromComment tgFromTags
+              , desFromEntries = fe
+              , desToEntries = te
+              , desToEntryBal = entry0 ta tgToComment tgToTags
               }
-          toEntry =
-            Entry
-              { eAcnt = ta
-              , eValue = ()
-              , eComment = ""
-              , eTags = []
-              }
-       in Tx
-            { dtxDate = trDate
-            , dtxDescr = trDesc
-            , dtxEntries =
-                EntrySet
-                  { desTotalValue = trAmount
-                  , desCurrency = cur
-                  , desFromEntry0 = fromEntry
-                  , desFromEntries = fe
-                  , desToEntries = te
-                  , desToEntryBal = toEntry
-                  }
-                  : ss
-            }
+              : ss
+        }
     where
       resolveAcnt_ = liftInner . resolveAcnt r
       acntRes =
@@ -353,6 +350,7 @@ toTx
         let teRes = mapErrors (resolveEntry cur r) tgToEntries
         combineError feRes teRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
+      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
 
 resolveSubGetter
   :: TxRecord

From 8d45614571a94f73e8b7068b9d50e5760e8e3f5b Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 17 Jun 2023 20:06:14 -0400
Subject: [PATCH 13/59] ADD defaults

---
 dhall/Types.dhall | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index c9c31c8..742b49f 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -500,6 +500,8 @@ let TxSubGetter =
         , tsgToTags = [] : List TagID
         , tsgFromComment = ""
         , tsgToComment = ""
+        , tsgFromEntries = [] : List EntryGetter.Type
+        , tsgToEntries = [] : List EntryGetter.Type
         }
       }
 
@@ -576,6 +578,8 @@ let TxGetter =
         { tgOtherEntries = [] : List TxSubGetter.Type
         , tgFromTags = [] : List TagID
         , tgToTags = [] : List TagID
+        , tgFromEntries = [] : List EntryGetter.Type
+        , tgToEntries = [] : List EntryGetter.Type
         , tgFromComment = ""
         , tgToComment = ""
         }

From 87e6dcff8f782286fb9da70a0a8352373fbd0f49 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 17 Jun 2023 20:57:24 -0400
Subject: [PATCH 14/59] FIX typos

---
 lib/Internal/History.hs     |  2 +-
 lib/Internal/Types/Dhall.hs |  4 ++++
 lib/Internal/Utils.hs       | 12 ++++++++----
 3 files changed, 13 insertions(+), 5 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 8d90ae0..6de2fe9 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -105,7 +105,7 @@ txPair day from to cur val desc =
     , dtxDate = day
     , dtxEntries =
         [ EntrySet
-            { desTotalValue = val
+            { desTotalValue = -val
             , desCurrency = cur
             , desFromEntry0 = entry from
             , desToEntryBal = entry to
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 9988d6d..a8e0a07 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -495,6 +495,10 @@ deriving instance Show (FieldMatcher T.Text)
 data TxSubGetter = TxSubGetter
   { tsgFromAcnt :: !EntryAcnt
   , tsgToAcnt :: !EntryAcnt
+  , tsgFromComment :: !T.Text
+  , tsgToComment :: !T.Text
+  , tsgFromTags :: ![TagID]
+  , tsgToTags :: ![TagID]
   , tsgValue :: !EntryNumGetter
   , tsgCurrency :: !EntryCur
   , tsgFromEntries :: ![EntryGetter]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 3bebb16..c902370 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -361,6 +361,10 @@ resolveSubGetter
   TxSubGetter
     { tsgFromAcnt
     , tsgToAcnt
+    , tsgFromTags
+    , tsgToTags
+    , tsgFromComment
+    , tsgToComment
     , tsgValue
     , tsgCurrency
     , tsgFromEntries
@@ -374,15 +378,15 @@ resolveSubGetter
             Entry
               { eAcnt = fa
               , eValue = ()
-              , eComment = "" -- TODO actually fill this in
-              , eTags = [] -- TODO what goes here?
+              , eComment = tsgFromComment
+              , eTags = tsgFromTags
               }
       let toEntry =
             Entry
               { eAcnt = ta
               , eValue = ()
-              , eComment = ""
-              , eTags = []
+              , eComment = tsgToComment
+              , eTags = tsgToTags
               }
       return
         EntrySet

From c2525fb77cfb48e72d4e326c8054042426200b02 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 18 Jun 2023 00:14:06 -0400
Subject: [PATCH 15/59] FIX balancing stuff

---
 lib/Internal/History.hs | 13 ++++---------
 1 file changed, 4 insertions(+), 9 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 6de2fe9..a87b65d 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -332,21 +332,18 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
--- TDOO should use a better type here to squish down all the entry sets
--- which at this point in the chain should not be necessary
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [(CommitR, DeferredTx)]
   -> m [(CommitR, KeyTx)]
 balanceTxs ts = do
-  keyts <- mapErrors resolveTx balTs
+  keyts <- mapErrors resolveTx $ snd $ L.mapAccumL go M.empty ts'
   return $ zip cs keyts
   where
     (cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
     go bals t@Tx {dtxEntries} =
       second (\es -> t {dtxEntries = concat es}) $
         L.mapAccumL balanceEntrySet bals dtxEntries
-    balTs = snd $ L.mapAccumL go M.empty ts'
 
 type EntryBals = M.Map (AcntID, CurID) Rational
 
@@ -384,14 +381,12 @@ balanceEntry
   -> EntryBals
   -> Entry AcntID (Deferred Rational) TagID
   -> (EntryBals, Entry AcntID Rational TagID)
-balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt}
-  | toBal = (bals, e {eValue = v})
-  | otherwise = (bals', e {eValue = newVal})
+balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt} =
+  (mapAdd_ key newVal bals, e {eValue = newVal})
   where
     key = (eAcnt, curID)
     curBal = M.findWithDefault 0 key bals
-    newVal = v - curBal
-    bals' = mapAdd_ key newVal bals
+    newVal = if toBal then v - curBal else v
 
 -- -- reimplementation from future version :/
 -- mapAccumM

From 03e75ce549012a7ded684551bddbbb93d05281c5 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:14:18 -0400
Subject: [PATCH 16/59] ADD linked credit entries

---
 dhall/Types.dhall           | 199 +++++++++++++++--------------
 dhall/common.dhall          |   4 +-
 lib/Internal/History.hs     |  99 +++++++++------
 lib/Internal/Types/Dhall.hs |  50 +++++---
 lib/Internal/Types/Main.hs  |  28 +++--
 lib/Internal/Utils.hs       | 243 +++++++++++++++++++++---------------
 6 files changed, 361 insertions(+), 262 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 742b49f..2b1c7e5 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -411,6 +411,35 @@ let EntryNumGetter =
       | BalanceN : Double
       >
 
+let LinkedNumGetter =
+    {-
+    Means to get a numeric value from another entry
+    -}
+      { Type =
+          { lngIndex :
+              {-
+              Index of the entry to link.
+              -}
+              Natural
+          , lngScale :
+              {-
+              Factor by which to multiply the value of the linked entry.
+              -}
+              Double
+          }
+      , default = { lngScale = 1, lngIndex = 0 }
+      }
+
+let LinkedEntryNumGetter =
+    {-
+    Means to get a numeric value from a statement row or another entry getter.
+
+    Linked: a number referring to the entry on the 'from' side of the
+    transaction (with 0 being the primary entry)
+    Getter: a normal getter
+    -}
+      < Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
+
 let EntryTextGetter =
     {-
     Means to get a textual value from a statement row.
@@ -473,115 +502,100 @@ let Entry =
 
 let EntryGetter =
     {-
-    Means for getting an entry from a given row in a statement
+    Means for getting an entry from a given row in a statement (debit side)
     -}
-      { Type = Entry EntryAcntGetter EntryNumGetter TagID
-      , default = { eComment = "", eTags = [] : List TagID }
-      }
+      \(n : Type) ->
+        { Type = Entry EntryAcntGetter n TagID
+        , default = { eComment = "", eTags = [] : List TagID }
+        }
+
+let FromEntryGetter =
+    {-
+    Means for getting an entry from a given row in a statement (debit side)
+    -}
+      EntryGetter EntryNumGetter
+
+let ToEntryGetter =
+    {-
+    Means for getting an entry from a given row in a statement (credit side)
+    -}
+      EntryGetter LinkedEntryNumGetter
+
+let TxHalfGetter =
+    {-
+    Means of transforming one row in a statement to either the credit or debit
+    half of a transaction
+    -}
+      \(e : Type) ->
+        { Type =
+            { thgAcnt :
+                {-
+                Account from which this transaction will be balanced. The value
+                of the transaction will be assigned to this account unless
+                other entries are specified (see below).
+
+                This account (and its associated entry) will be denoted
+                'primary'.
+                -}
+                EntryAcntGetter
+            , thgEntries :
+                {-
+                Means of getting additional entries from which this transaction
+                will be balanced. If this list is empty, the total value of the
+                transaction will be assigned to the value defined by 'tsgAcnt'.
+                Otherwise, the entries specified here will be added to this side
+                of this transaction, and their sum value will be subtracted from
+                the total value of the transaction and assigned to 'tsgAcnt'.
+
+                This is useful for situations where a particular transaction
+                denotes values that come from multiple subaccounts.
+                -}
+                List e
+            , thgComment :
+                {-
+                Comment for the primary entry
+                -}
+                Text
+            , thgTags :
+                {-
+                Tags for the primary entry
+                -}
+                List TagID
+            }
+        , default =
+          { thgTags = [] : List TagID
+          , thgComment = ""
+          , thgEntries = [] : List e
+          }
+        }
 
 let TxSubGetter =
     {-
     A means for transforming one row in a statement to a transaction
     -}
       { Type =
-          { tsgFromAcnt : EntryAcntGetter
-          , tsgToAcnt : EntryAcntGetter
-          , tsgValue : EntryNumGetter
+          { tsgValue : EntryNumGetter
           , tsgCurrency : EntryCurGetter
-          , tsgFromEntries : List EntryGetter.Type
-          , tsgFromComment : Text
-          , tsgToComment : Text
-          , tsgFromTags : List TagID
-          , tsgToTags : List TagID
-          , tsgToEntries : List EntryGetter.Type
+          , tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
+          , tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
           }
-      , default =
-        { tsgFromTags = [] : List TagID
-        , tsgToTags = [] : List TagID
-        , tsgFromComment = ""
-        , tsgToComment = ""
-        , tsgFromEntries = [] : List EntryGetter.Type
-        , tsgToEntries = [] : List EntryGetter.Type
-        }
+      , default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
       }
 
 let TxGetter =
     {-
     A means for transforming one row in a statement to a transaction
-
-    At least two entries must be made for any given transaction. Below these
-    correspond to the 'from' and 'to' accounts, which will share a single value
-    (whose positive is added to 'to' and negative is added to 'from' accounts)
-    given by the record (ie one row in a statement) denominated in the given
-    currency.
-
-    Optionally, both sides of the from/to flow of value can be split with other
-    accounts (given by 'tgFromEntries' and 'tgToEntries'). In either case, the
-    amount actually transferred between the 'from' and 'to' accounts above
-    will be the difference after considering these additional account entries.
-
-    Furthermore, additionally entries denominated in different currencies
-    may be specified via 'tgOtherEntries'. Each member in this list corresponds
-    to a different currency (and associated entries) governed by most of the
-    rules for this type regarding balancing and splitting value.
-
     -}
       { Type =
-          { tgFromAcnt :
-              {-
-              Account from which this transaction will be balanced. The value of
-              the transaction will be assigned to this account unless other from
-              entries are specified (see below).
-              -}
-              EntryAcntGetter
-          , tgToAcnt :
-              {-
-              Account from which this transaction will be balanced. The value of
-              the transaction will be assigned to this account unless other from
-              entries are specified (see below).
-              -}
-              EntryAcntGetter
-          , tgFromComment : Text
-          , tgToComment : Text
-          , tgFromTags : List TagID
-          , tgToTags : List TagID
-          , tgCurrency :
-              {-
-              Currency to assign to the account/value denoted by 'tgFromAcnt'
-              above.
-              -}
-              EntryCurGetter
-          , tgFromEntries :
-              {-
-              Means of getting additional entries from which this transaction will
-              be balanced (minimum 0). If this list is empty, the total value of the
-              transaction will be assigned to the value defined by 'tgFromAcnt'.
-              Otherwise, the entries specified here will be added to the credit side
-              of this transaction, and their sum value will be subtracted from the
-              total value of the transaction and assigned to 'tgFromAcnt'.
-
-              This is useful for situations where a particular transaction denotes
-              values that come from multiple subaccounts.
-              -}
-              List EntryGetter.Type
-          , tgToEntries :
-              {-
-              A means of getting entries for this transaction
-              -}
-              List EntryGetter.Type
-          , tgOtherEntries :
-              {-
-              -}
-              List TxSubGetter.Type
+          { tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
+          , tgTo : (TxHalfGetter ToEntryGetter.Type).Type
+          , tgCurrency : EntryCurGetter
+          , tgOtherEntries : List TxSubGetter.Type
           }
       , default =
         { tgOtherEntries = [] : List TxSubGetter.Type
-        , tgFromTags = [] : List TagID
-        , tgToTags = [] : List TagID
-        , tgFromEntries = [] : List EntryGetter.Type
-        , tgToEntries = [] : List EntryGetter.Type
-        , tgFromComment = ""
-        , tgToComment = ""
+        , tsgFrom = TxHalfGetter
+        , tsgTo = TxHalfGetter
         }
       }
 
@@ -1128,10 +1142,13 @@ in  { CurID
     , FieldMatcher
     , FieldMatcher_
     , EntryNumGetter
+    , LinkedEntryNumGetter
+    , LinkedNumGetter
     , Field
     , FieldMap
     , Entry
-    , EntryGetter
+    , FromEntryGetter
+    , ToEntryGetter
     , EntryTextGetter
     , EntryCurGetter
     , EntryAcntGetter
diff --git a/dhall/common.dhall b/dhall/common.dhall
index 0f2a6e2..432790a 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -7,7 +7,7 @@ let T = ./Types.dhall
 let nullEntry =
       \(a : T.EntryAcntGetter) ->
       \(v : T.EntryNumGetter) ->
-        T.EntryGetter::{ eAcnt = a, eValue = v }
+        T.FromEntryGetter::{ eAcnt = a, eValue = v }
 
 let nullOpts = T.TxOpts::{=}
 
@@ -99,7 +99,7 @@ let partN =
                       (T.EntryNumGetter.ConstN x._2)
                 //  { eComment = x._3 }
 
-        in  List/map PartEntry T.EntryGetter.Type toEntry ss
+        in  List/map PartEntry T.FromEntryGetter.Type toEntry ss
 
 let addDay =
       \(x : T.GregorianM) ->
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index a87b65d..3b481c6 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -69,7 +69,7 @@ readHistStmt
 readHistStmt root i = whenHash_ CTImport i $ do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
-  return $ filter (inDaySpan bounds . dtxDate) bs
+  return $ filter (inDaySpan bounds . txDate) bs
 
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
@@ -101,16 +101,14 @@ txPair
   -> DeferredTx
 txPair day from to cur val desc =
   Tx
-    { dtxDescr = desc
-    , dtxDate = day
-    , dtxEntries =
+    { txDescr = desc
+    , txDate = day
+    , txEntries =
         [ EntrySet
-            { desTotalValue = -val
-            , desCurrency = cur
-            , desFromEntry0 = entry from
-            , desToEntryBal = entry to
-            , desFromEntries = []
-            , desToEntries = []
+            { esTotalValue = -val
+            , esCurrency = cur
+            , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
+            , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
             }
         ]
     }
@@ -124,11 +122,11 @@ txPair day from to cur val desc =
         }
 
 resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
-resolveTx t@Tx {dtxEntries = ss} =
-  (\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
+resolveTx t@Tx {txEntries = ss} =
+  (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
 insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
-insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
+insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
   k <- insert $ TransactionR c d e
   mapM_ (insertEntry k) ss
 
@@ -337,56 +335,75 @@ balanceTxs
   => [(CommitR, DeferredTx)]
   -> m [(CommitR, KeyTx)]
 balanceTxs ts = do
-  keyts <- mapErrors resolveTx $ snd $ L.mapAccumL go M.empty ts'
+  keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty
   return $ zip cs keyts
   where
-    (cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
-    go bals t@Tx {dtxEntries} =
-      second (\es -> t {dtxEntries = concat es}) $
-        L.mapAccumL balanceEntrySet bals dtxEntries
+    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
+    go t@Tx {txEntries} =
+      (\es -> t {txEntries = concat es}) <$> mapM balanceEntrySet txEntries
 
 type EntryBals = M.Map (AcntID, CurID) Rational
 
 -- TODO might be faster to also do all the key stuff here since currency
 -- will be looked up for every entry rather then the entire entry set
-balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
 balanceEntrySet
-  bals
+  :: (MonadInsertError m, MonadFinance m)
+  => DeferredEntrySet
+  -> StateT EntryBals m [BalEntry]
+balanceEntrySet
   EntrySet
-    { desFromEntry0
-    , desFromEntries
-    , desToEntryBal
-    , desToEntries
-    , desCurrency
-    , desTotalValue
-    } = flipTup $ runState doBalAll bals
+    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
+    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
+    , esCurrency
+    , esTotalValue
+    } =
+    do
+      let (lts, dts) = partitionEithers $ splitLinked <$> ts
+      fs' <- doEntries fs esTotalValue f0
+      let fv = V.fromList $ fmap eValue fs'
+      lts' <- lift $ mapErrors (resolveLinked fv esCurrency) lts
+      ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
+      return $ toFull <$> fs' ++ ts'
     where
-      flipTup (a, b) = (b, a)
       doEntries es tot e0 = do
-        es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
+        es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
         let val0 = tot - entrySum es'
-        modify $ mapAdd_ (eAcnt e0, desCurrency) val0
+        modify $ mapAdd_ (eAcnt e0, esCurrency) val0
         return $ e0 {eValue = val0} : es'
-      doBalAll = do
-        fes <- doEntries desFromEntries desTotalValue desFromEntry0
-        tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
-        return $ toFull <$> fes ++ tes
-      toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
+      toFull e = FullEntry {feEntry = e, feCurrency = esCurrency}
+      splitLinked e@Entry {eValue} = case eValue of
+        LinkIndex l -> Left e {eValue = l}
+        LinkDeferred d -> Right e {eValue = d}
+      liftInnerS = mapStateT (return . runIdentity)
+
+resolveLinked
+  :: (MonadInsertError m, MonadFinance m)
+  => Vector Rational
+  -> CurID
+  -> Entry a LinkedNumGetter t
+  -> m (Entry a (Deferred Rational) t)
+resolveLinked from cur e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
+  curMap <- askDBState kmCurrency
+  case from V.!? fromIntegral lngIndex of
+    Nothing -> throwError undefined
+    Just v -> do
+      v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
+      return $ e {eValue = Deferred False v'}
 
 entrySum :: Num v => [Entry a v t] -> v
 entrySum = sum . fmap eValue
 
 balanceEntry
   :: CurID
-  -> EntryBals
   -> Entry AcntID (Deferred Rational) TagID
-  -> (EntryBals, Entry AcntID Rational TagID)
-balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt} =
-  (mapAdd_ key newVal bals, e {eValue = newVal})
+  -> State EntryBals (Entry AcntID Rational TagID)
+balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do
+  curBal <- gets (M.findWithDefault 0 key)
+  let newVal = if toBal then v - curBal else v
+  modify (mapAdd_ key newVal)
+  return $ e {eValue = newVal}
   where
     key = (eAcnt, curID)
-    curBal = M.findWithDefault 0 key bals
-    newVal = if toBal then v - curBal else v
 
 -- -- reimplementation from future version :/
 -- mapAccumM
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index a8e0a07..04b5f86 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -33,10 +33,12 @@ makeHaskellTypesWith
   , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
   , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
+  , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
+  , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
   , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
@@ -98,6 +100,8 @@ deriveProduct
   , "BudgetCurrency"
   , "Exchange"
   , "EntryNumGetter"
+  , "LinkedNumGetter"
+  , "LinkedEntryNumGetter"
   , "TemporalScope"
   , "SqlConfig"
   , "PretaxValue"
@@ -340,6 +344,10 @@ instance Ord DateMatcher where
 
 deriving instance Hashable EntryNumGetter
 
+deriving instance Hashable LinkedNumGetter
+
+deriving instance Hashable LinkedEntryNumGetter
+
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
 -- account tree type
@@ -421,9 +429,15 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
+type EntryGetter n = Entry EntryAcnt n TagID
 
-instance FromDhall EntryGetter
+type FromEntryGetter = EntryGetter EntryNumGetter
+
+type ToEntryGetter = EntryGetter LinkedEntryNumGetter
+
+instance FromDhall FromEntryGetter
+
+instance FromDhall ToEntryGetter
 
 deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
 
@@ -492,30 +506,30 @@ data FieldMatcher re
 
 deriving instance Show (FieldMatcher T.Text)
 
+data TxHalfGetter e = TxHalfGetter
+  { thgAcnt :: !EntryAcnt
+  , thgComment :: !T.Text
+  , thgTags :: ![TagID]
+  , thgEntries :: ![e]
+  }
+  deriving (Eq, Generic, Hashable, Show)
+
+deriving instance FromDhall (TxHalfGetter FromEntryGetter)
+
+deriving instance FromDhall (TxHalfGetter ToEntryGetter)
+
 data TxSubGetter = TxSubGetter
-  { tsgFromAcnt :: !EntryAcnt
-  , tsgToAcnt :: !EntryAcnt
-  , tsgFromComment :: !T.Text
-  , tsgToComment :: !T.Text
-  , tsgFromTags :: ![TagID]
-  , tsgToTags :: ![TagID]
+  { tsgFrom :: !(TxHalfGetter FromEntryGetter)
+  , tsgTo :: !(TxHalfGetter ToEntryGetter)
   , tsgValue :: !EntryNumGetter
   , tsgCurrency :: !EntryCur
-  , tsgFromEntries :: ![EntryGetter]
-  , tsgToEntries :: ![EntryGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
 data TxGetter = TxGetter
-  { tgFromAcnt :: !EntryAcnt
-  , tgToAcnt :: !EntryAcnt
-  , tgFromComment :: !T.Text
-  , tgToComment :: !T.Text
-  , tgFromTags :: ![TagID]
-  , tgToTags :: ![TagID]
+  { tgFrom :: !(TxHalfGetter FromEntryGetter)
+  , tgTo :: !(TxHalfGetter ToEntryGetter)
   , tgCurrency :: !EntryCur
-  , tgFromEntries :: ![EntryGetter]
-  , tgToEntries :: ![EntryGetter]
   , tgOtherEntries :: ![TxSubGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index e4be06e..4495db2 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -138,23 +138,26 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
+data HalfEntrySet a c t v = HalfEntrySet
+  { hesPrimary :: !(Entry a () t)
+  , hesOther :: ![Entry a v t]
+  }
+
 data EntrySet a c t v = EntrySet
-  { desTotalValue :: !Rational
-  , desCurrency :: !c
-  , desFromEntry0 :: !(Entry a () t)
-  , desFromEntries :: ![Entry a v t]
-  , desToEntries :: ![Entry a v t]
-  , desToEntryBal :: !(Entry a () t)
+  { esTotalValue :: !Rational
+  , esCurrency :: !c
+  , esFrom :: !(HalfEntrySet a c t (Deferred v))
+  , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
   }
 
 data Tx e = Tx
-  { dtxDescr :: !T.Text
-  , dtxDate :: !Day
-  , dtxEntries :: !e
+  { txDescr :: !T.Text
+  , txDate :: !Day
+  , txEntries :: !e
   }
   deriving (Generic)
 
-type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
+type DeferredEntrySet = EntrySet AcntID CurID TagID Rational
 
 type BalEntrySet = EntrySet AcntID CurID TagID Rational
 
@@ -169,6 +172,11 @@ type KeyTx = Tx [KeyEntry]
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
+data LinkDeferred a
+  = LinkDeferred (Deferred a)
+  | LinkIndex LinkedNumGetter
+  deriving (Show, Functor, Foldable, Traversable)
+
 -- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index c902370..af8ca25 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -310,105 +310,131 @@ matches
 toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
 toTx
   TxGetter
-    { tgFromAcnt
-    , tgToAcnt
-    , tgFromComment
-    , tgToComment
-    , tgFromTags
-    , tgToTags
+    { tgFrom
+    , tgTo
     , tgCurrency
-    , tgFromEntries
-    , tgToEntries
     , tgOtherEntries
     }
   r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss ->
+    combineError curRes subRes $ \(cur, f, t) ss ->
       Tx
-        { dtxDate = trDate
-        , dtxDescr = trDesc
-        , dtxEntries =
+        { txDate = trDate
+        , txDescr = trDesc
+        , txEntries =
             EntrySet
-              { desTotalValue = trAmount
-              , desCurrency = cur
-              , desFromEntry0 = entry0 fa tgFromComment tgFromTags
-              , desFromEntries = fe
-              , desToEntries = te
-              , desToEntryBal = entry0 ta tgToComment tgToTags
+              { esTotalValue = trAmount
+              , esCurrency = cur
+              , esFrom = f
+              , esTo = t
               }
               : ss
         }
     where
-      resolveAcnt_ = liftInner . resolveAcnt r
-      acntRes =
-        combineError
-          (resolveAcnt_ tgFromAcnt)
-          (resolveAcnt_ tgToAcnt)
-          (,)
       curRes = do
         cur <- liftInner $ resolveCurrency r tgCurrency
-        let feRes = mapErrors (resolveEntry cur r) tgFromEntries
-        let teRes = mapErrors (resolveEntry cur r) tgToEntries
-        combineError feRes teRes (cur,,)
+        let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
+        let toRes = resolveHalfEntry resolveToValue cur r tgTo
+        combineError fromRes toRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
-      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
 
 resolveSubGetter
   :: TxRecord
   -> TxSubGetter
-  -> InsertExceptT CurrencyM DeferredEntrySet
-resolveSubGetter
-  r
-  TxSubGetter
-    { tsgFromAcnt
-    , tsgToAcnt
-    , tsgFromTags
-    , tsgToTags
-    , tsgFromComment
-    , tsgToComment
-    , tsgValue
-    , tsgCurrency
-    , tsgFromEntries
-    , tsgToEntries
-    } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
-    do
-      m <- ask
-      -- TODO laaaaame...
-      (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
-      let fromEntry =
-            Entry
-              { eAcnt = fa
-              , eValue = ()
-              , eComment = tsgFromComment
-              , eTags = tsgFromTags
-              }
-      let toEntry =
-            Entry
-              { eAcnt = ta
-              , eValue = ()
-              , eComment = tsgToComment
-              , eTags = tsgToTags
-              }
-      return
-        EntrySet
-          { desTotalValue = val
-          , desCurrency = cur
-          , desFromEntry0 = fromEntry
-          , desFromEntries = fe
-          , desToEntries = te
-          , desToEntryBal = toEntry
-          }
-    where
-      resolveAcnt_ = liftInner . resolveAcnt r
-      acntRes =
-        combineError
-          (resolveAcnt_ tsgFromAcnt)
-          (resolveAcnt_ tsgToAcnt)
-          (,)
-      curRes = do
-        cur <- liftInner $ resolveCurrency r tsgCurrency
-        let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
-        let teRes = mapErrors (resolveEntry cur r) tsgToEntries
-        combineError feRes teRes (cur,,)
+  -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
+resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
+  m <- ask
+  cur <- liftInner $ resolveCurrency r tsgCurrency
+  (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
+  let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
+  let toRes = resolveHalfEntry resolveToValue cur r tsgTo
+  combineError fromRes toRes $ \f t ->
+    EntrySet
+      { esTotalValue = val
+      , esCurrency = cur
+      , esFrom = f
+      , esTo = t
+      }
+
+resolveHalfEntry
+  :: Traversable f
+  => (TxRecord -> n -> InsertExcept (f Double))
+  -> CurID
+  -> TxRecord
+  -> TxHalfGetter (EntryGetter n)
+  -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational))
+resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+  combineError acntRes esRes $ \a es ->
+    HalfEntrySet
+      { hesPrimary =
+          Entry
+            { eAcnt = a
+            , eValue = ()
+            , eComment = thgComment
+            , eTags = thgTags
+            }
+      , hesOther = es
+      }
+  where
+    acntRes = liftInner $ resolveAcnt r thgAcnt
+    esRes = mapErrors (resolveEntry f cur r) thgEntries
+
+-- resolveSubGetter
+--   :: TxRecord
+--   -> TxSubGetter
+--   -> InsertExceptT CurrencyM DeferredEntrySet
+-- resolveSubGetter
+--   r
+--   TxSubGetter
+--     { tsgFromAcnt
+--     , tsgToAcnt
+--     , tsgFromTags
+--     , tsgToTags
+--     , tsgFromComment
+--     , tsgToComment
+--     , tsgValue
+--     , tsgCurrency
+--     , tsgFromEntries
+--     , tsgToEntries
+--     } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
+--     do
+--       m <- ask
+--       -- TODO laaaaame...
+--       (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
+--       let fromEntry =
+--             Entry
+--               { eAcnt = fa
+--               , eValue = ()
+--               , eComment = tsgFromComment
+--               , eTags = tsgFromTags
+--               }
+--       let toEntry =
+--             Entry
+--               { eAcnt = ta
+--               , eValue = ()
+--               , eComment = tsgToComment
+--               , eTags = tsgToTags
+--               }
+--       return
+--         EntrySet
+--           { desTotalValue = val
+--           , desCurrency = cur
+--           , desFromEntry0 = fromEntry
+--           , desFromEntries = fe
+--           , desToEntries = te
+--           , desToEntryBal = toEntry
+--           }
+--     where
+--       resolveAcnt_ = liftInner . resolveAcnt r
+--       acntRes =
+--         combineError
+--           (resolveAcnt_ tsgFromAcnt)
+--           (resolveAcnt_ tsgToAcnt)
+--           (,)
+--       curRes = do
+--         cur <- liftInner $ resolveCurrency r tsgCurrency
+--         let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
+--         let teRes = mapErrors (resolveEntry cur r) tsgToEntries
+--         combineError feRes teRes (cur,,)
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -434,20 +460,35 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
--- TODO this should be more general?
 resolveEntry
-  :: CurID
+  :: Traversable f
+  => (TxRecord -> n -> InsertExcept (f Double))
+  -> CurID
   -> TxRecord
-  -> EntryGetter
-  -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
-resolveEntry cur r s@Entry {eAcnt, eValue} = do
+  -> EntryGetter n
+  -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID)
+resolveEntry f cur r s@Entry {eAcnt, eValue} = do
   m <- ask
   liftInner $ combineErrorM acntRes valRes $ \a v -> do
     v' <- mapM (roundPrecisionCur cur m) v
     return $ s {eAcnt = a, eValue = v'}
   where
     acntRes = resolveAcnt r eAcnt
-    valRes = resolveValue r eValue
+    valRes = f r eValue
+
+-- resolveEntry
+--   :: CurID
+--   -> TxRecord
+--   -> EntryGetter n
+--   -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
+-- resolveEntry cur r s@Entry {eAcnt, eValue} = do
+--   m <- ask
+--   liftInner $ combineErrorM acntRes valRes $ \a v -> do
+--     v' <- mapM (roundPrecisionCur cur m) v
+--     return $ s {eAcnt = a, eValue = v'}
+--   where
+--     acntRes = resolveAcnt r eAcnt
+--     valRes = resolveValue r eValue
 
 -- curRes = resolveCurrency r eCurrency
 
@@ -556,19 +597,21 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
 collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
-resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return $ Deferred False c
-  AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
-  BalanceN x -> return $ Deferred True x
+resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
+resolveFromValue r = fmap (uncurry Deferred) . resolveValue r
 
--- -- TODO not DRY
--- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
--- resolveToValue TxRecord {trOther, trAmount} s = case s of
---   (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
---   (TConstN c) -> return c
---   TAmountN m -> return $ (* m) $ fromRational trAmount
+resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
+resolveToValue _ (Linked l) = return $ LinkIndex l
+resolveToValue r (Getter g) = do
+  (l, v) <- resolveValue r g
+  return $ LinkDeferred (Deferred l v)
+
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double)
+resolveValue TxRecord {trOther, trAmount} s = case s of
+  (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (ConstN c) -> return (False, c)
+  AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount
+  BalanceN x -> return (True, x)
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField

From f3d2c1655e0e757110bef79d49ab8cd390ba4989 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:33:50 -0400
Subject: [PATCH 17/59] FIX undefined error paths

---
 lib/Internal/History.hs    | 19 +++++++++++--------
 lib/Internal/Types/Main.hs |  5 +++--
 lib/Internal/Utils.hs      | 18 +++++++++++++++++-
 3 files changed, 31 insertions(+), 11 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 3b481c6..e6a24ec 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -339,8 +339,8 @@ balanceTxs ts = do
   return $ zip cs keyts
   where
     (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
-    go t@Tx {txEntries} =
-      (\es -> t {txEntries = concat es}) <$> mapM balanceEntrySet txEntries
+    go t@Tx {txEntries, txDate} =
+      (\es -> t {txEntries = concat es}) <$> mapM (balanceEntrySet txDate) txEntries
 
 type EntryBals = M.Map (AcntID, CurID) Rational
 
@@ -348,9 +348,11 @@ type EntryBals = M.Map (AcntID, CurID) Rational
 -- will be looked up for every entry rather then the entire entry set
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => DeferredEntrySet
+  => Day
+  -> DeferredEntrySet
   -> StateT EntryBals m [BalEntry]
 balanceEntrySet
+  day
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -361,7 +363,7 @@ balanceEntrySet
       let (lts, dts) = partitionEithers $ splitLinked <$> ts
       fs' <- doEntries fs esTotalValue f0
       let fv = V.fromList $ fmap eValue fs'
-      lts' <- lift $ mapErrors (resolveLinked fv esCurrency) lts
+      lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
       ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
       return $ toFull <$> fs' ++ ts'
     where
@@ -380,12 +382,13 @@ resolveLinked
   :: (MonadInsertError m, MonadFinance m)
   => Vector Rational
   -> CurID
-  -> Entry a LinkedNumGetter t
-  -> m (Entry a (Deferred Rational) t)
-resolveLinked from cur e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
+  -> Day
+  -> Entry AcntID LinkedNumGetter TagID
+  -> m (Entry AcntID (Deferred Rational) TagID)
+resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
   curMap <- askDBState kmCurrency
   case from V.!? fromIntegral lngIndex of
-    Nothing -> throwError undefined
+    Nothing -> throwError $ InsertException [IndexError e day]
     Just v -> do
       v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
       return $ e {eValue = Deferred False v'}
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 4495db2..a5f520c 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -221,9 +221,10 @@ data InsertError
   | InsertIOError !T.Text
   | ParseError !T.Text
   | ConversionError !T.Text
+  | IndexError !(Entry AcntID LinkedNumGetter TagID) !Day
+  | RoundError !CurID
   | LookupError !LookupSuberr !T.Text
-  | -- | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
-    IncomeError !Day !T.Text !Rational
+  | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index af8ca25..ac3d062 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -708,7 +708,7 @@ roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
 roundPrecisionCur c m x =
   case M.lookup c m of
     Just (_, n) -> return $ roundPrecision n x
-    Nothing -> throwError $ InsertException [undefined]
+    Nothing -> throwError $ InsertException [RoundError c]
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -786,6 +786,22 @@ showError other = case other of
         , singleQuote $ showT next
         ]
     ]
+  (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
+    [ T.unwords
+        [ "No credit entry for index"
+        , singleQuote $ showT lngIndex
+        , "for entry with account"
+        , singleQuote eAcnt
+        , "on"
+        , showT day
+        ]
+    ]
+  (RoundError cur) ->
+    [ T.unwords
+        [ "Could not look up precision for currency"
+        , singleQuote cur
+        ]
+    ]
 
 showGregorian_ :: Gregorian -> T.Text
 showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]

From 024a57179dc06dbf61632d557b48dee05693f835 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:39:56 -0400
Subject: [PATCH 18/59] FIX half getter expiort

---
 dhall/Types.dhall | 1 +
 1 file changed, 1 insertion(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 2b1c7e5..2c335b0 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -1178,6 +1178,7 @@ in  { CurID
     , BudgetTransferType
     , TxGetter
     , TxSubGetter
+    , TxHalfGetter
     , HistTransfer
     , SingleAllocation
     , MultiAllocation

From ec74e735d0cdead1e17f1d34eb216a33aca0c15a Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:41:57 -0400
Subject: [PATCH 19/59] FIX more exports

---
 dhall/Types.dhall | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 2c335b0..0007368 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -569,6 +569,10 @@ let TxHalfGetter =
           }
         }
 
+let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
+
+let ToTxHalfGetter = TxHalfGetter FromEntryGetter.Type
+
 let TxSubGetter =
     {-
     A means for transforming one row in a statement to a transaction
@@ -1179,6 +1183,8 @@ in  { CurID
     , TxGetter
     , TxSubGetter
     , TxHalfGetter
+    , FromTxHalfGetter
+    , ToTxHalfGetter
     , HistTransfer
     , SingleAllocation
     , MultiAllocation

From 845899d0739dff3e715487d4239deeec2420709d Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:43:16 -0400
Subject: [PATCH 20/59] FIX typo

---
 dhall/Types.dhall | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 0007368..b31d93d 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -571,7 +571,7 @@ let TxHalfGetter =
 
 let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
 
-let ToTxHalfGetter = TxHalfGetter FromEntryGetter.Type
+let ToTxHalfGetter = TxHalfGetter ToEntryGetter.Type
 
 let TxSubGetter =
     {-

From 352cc88eedb88e4689d86e32e065afbb779d3162 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 12:44:14 -0400
Subject: [PATCH 21/59] FIX more typos

---
 dhall/Types.dhall | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index b31d93d..d9a4c3e 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -598,8 +598,8 @@ let TxGetter =
           }
       , default =
         { tgOtherEntries = [] : List TxSubGetter.Type
-        , tsgFrom = TxHalfGetter
-        , tsgTo = TxHalfGetter
+        , tgFrom = TxHalfGetter
+        , tgTo = TxHalfGetter
         }
       }
 

From 33678e3908bc88e9ad66e2cc97b4a7bf9016e167 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 13:00:23 -0400
Subject: [PATCH 22/59] FIX yet another typo

---
 dhall/Types.dhall | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index d9a4c3e..3333671 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -427,7 +427,7 @@ let LinkedNumGetter =
               -}
               Double
           }
-      , default = { lngScale = 1, lngIndex = 0 }
+      , default = { lngScale = 1.0, lngIndex = 0 }
       }
 
 let LinkedEntryNumGetter =

From 4c881516101a5646471c69fa4c673fafd8af8b99 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 19 Jun 2023 13:21:20 -0400
Subject: [PATCH 23/59] ENH split partn

---
 dhall/common.dhall | 27 +++++++++++++++++++++------
 1 file changed, 21 insertions(+), 6 deletions(-)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index 432790a..0283bb6 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -90,17 +90,31 @@ let mRngYMD =
 
 let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
 
-let partN =
+let partNFrom =
       \(ss : List PartEntry) ->
         let toEntry =
               \(x : PartEntry) ->
-                    nullEntry
-                      (T.EntryAcntGetter.ConstT x._1)
-                      (T.EntryNumGetter.ConstN x._2)
-                //  { eComment = x._3 }
+                T.FromEntryGetter::{
+                , eAcnt = T.EntryAcntGetter.ConstT x._1
+                , eValue = T.EntryNumGetter.ConstN x._2
+                , eComment = x._3
+                }
 
         in  List/map PartEntry T.FromEntryGetter.Type toEntry ss
 
+let partNTo =
+      \(ss : List PartEntry) ->
+        let toEntry =
+              \(x : PartEntry) ->
+                T.ToEntryGetter::{
+                , eAcnt = T.EntryAcntGetter.ConstT x._1
+                , eValue =
+                    T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
+                , eComment = x._3
+                }
+
+        in  List/map PartEntry T.ToEntryGetter.Type toEntry ss
+
 let addDay =
       \(x : T.GregorianM) ->
       \(d : Natural) ->
@@ -143,7 +157,8 @@ in      { nullEntry
         , match1
         , greg
         , gregM
-        , partN
+        , partNFrom
+        , partNTo
         , addDay
         , comma = 44
         , tab = 9

From 09e03ff67552180987bf272ad59d83429d6f0bc1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 20 Jun 2023 22:52:52 -0400
Subject: [PATCH 24/59] ADD means to scale/flip the value of a transaction

---
 dhall/Types.dhall           |  2 ++
 lib/Internal/Types/Dhall.hs |  1 +
 lib/Internal/Utils.hs       | 12 +++++++++---
 3 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 3333671..c0856d4 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -593,6 +593,7 @@ let TxGetter =
       { Type =
           { tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
           , tgTo : (TxHalfGetter ToEntryGetter.Type).Type
+          , tgScale : Double
           , tgCurrency : EntryCurGetter
           , tgOtherEntries : List TxSubGetter.Type
           }
@@ -600,6 +601,7 @@ let TxGetter =
         { tgOtherEntries = [] : List TxSubGetter.Type
         , tgFrom = TxHalfGetter
         , tgTo = TxHalfGetter
+        , tgScale = 1.0
         }
       }
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 04b5f86..c677299 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -531,6 +531,7 @@ data TxGetter = TxGetter
   , tgTo :: !(TxHalfGetter ToEntryGetter)
   , tgCurrency :: !EntryCur
   , tgOtherEntries :: ![TxSubGetter]
+  , tgScale :: !Double
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index ac3d062..0824b50 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -314,15 +314,16 @@ toTx
     , tgTo
     , tgCurrency
     , tgOtherEntries
+    , tgScale
     }
   r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError curRes subRes $ \(cur, f, t) ss ->
+    combineError curRes subRes $ \(cur, f, t, v) ss ->
       Tx
         { txDate = trDate
         , txDescr = trDesc
         , txEntries =
             EntrySet
-              { esTotalValue = trAmount
+              { esTotalValue = v
               , esCurrency = cur
               , esFrom = f
               , esTo = t
@@ -331,10 +332,15 @@ toTx
         }
     where
       curRes = do
+        m <- ask
         cur <- liftInner $ resolveCurrency r tgCurrency
         let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
         let toRes = resolveHalfEntry resolveToValue cur r tgTo
-        combineError fromRes toRes (cur,,)
+        let totRes =
+              liftExcept $
+                roundPrecisionCur cur m $
+                  tgScale * fromRational trAmount
+        combineError3 fromRes toRes totRes (cur,,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
 resolveSubGetter

From 5697a071ab074cd3f9e92203ba4c1b40d136013a Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 22 Jun 2023 23:27:14 -0400
Subject: [PATCH 25/59] WIP add lots of stuff to cache deferred calculations

---
 lib/Internal/Database.hs       |  23 +++++--
 lib/Internal/History.hs        | 109 +++++++++++++++++++++++++++++----
 lib/Internal/Types/Database.hs |   4 ++
 lib/Internal/Types/Main.hs     |   4 ++
 lib/Internal/Utils.hs          |  13 ++++
 5 files changed, 135 insertions(+), 18 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 3c64fea..6457541 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -11,9 +11,7 @@ module Internal.Database
   , whenHash
   , whenHash_
   , insertEntry
-  -- , insertEntrySet
   , resolveEntry
-  -- , resolveEntrySet
   )
 where
 
@@ -395,10 +393,23 @@ whenHash_ t o f = do
   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
 insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
-insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do
-  k <- insert $ EntryR t feCurrency eAcnt eComment eValue
-  mapM_ (insert_ . TagRelationR k) eTags
-  return k
+insertEntry
+  t
+  FullEntry
+    { feEntry = Entry {eValue, eTags, eAcnt, eComment}
+    , feCurrency
+    , feIndex
+    , feDeferred
+    } =
+    do
+      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex defval deflink
+      mapM_ (insert_ . TagRelationR k) eTags
+      return k
+    where
+      (defval, deflink) = case feDeferred of
+        (Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index)
+        (Just (EntryBalance target)) -> (Just target, Nothing)
+        Nothing -> (Nothing, Nothing)
 
 resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
 resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index e6a24ec..c53a02d 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -360,23 +360,49 @@ balanceEntrySet
     , esTotalValue
     } =
     do
-      let (lts, dts) = partitionEithers $ splitLinked <$> ts
       fs' <- doEntries fs esTotalValue f0
+      -- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs'
       let fv = V.fromList $ fmap eValue fs'
+      let (lts, dts) = partitionEithers $ splitLinked <$> ts
       lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
       ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
-      return $ toFull <$> fs' ++ ts'
+      -- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts'
+      return $ fs' -- ++ ts''
     where
       doEntries es tot e0 = do
+        es' <- liftInnerS $ mapM (uncurry (balanceEntry esCurrency)) $ zip [1 ..] es
+        let val0 = tot - entrySum es'
+        modify $ mapAdd_ (eAcnt e0, esCurrency) val0
+        return $ e0 {eValue = val0} : es'
+      doEntriesTo es tot e0 = do
         es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
         let val0 = tot - entrySum es'
         modify $ mapAdd_ (eAcnt e0, esCurrency) val0
         return $ e0 {eValue = val0} : es'
-      toFull e = FullEntry {feEntry = e, feCurrency = esCurrency}
+      toFullDebit i e target =
+        FullEntry
+          { feEntry = e
+          , feCurrency = esCurrency
+          , feIndex = i
+          , feDeferred = EntryBalance target
+          }
       splitLinked e@Entry {eValue} = case eValue of
         LinkIndex l -> Left e {eValue = l}
         LinkDeferred d -> Right e {eValue = d}
-      liftInnerS = mapStateT (return . runIdentity)
+      entrySum = sum . fmap (eValue . feEntry)
+
+liftInnerS = mapStateT (return . runIdentity)
+
+resolveCreditEntry
+  :: (MonadInsertError m, MonadFinance m)
+  => Vector Rational
+  -> CurID
+  -> Day
+  -> Int
+  -> Entry AcntID LinkedNumGetter TagID
+  -> m (FullEntry AcntID CurID TagID)
+resolveCreditEntry from cur day index e@Entry {eValue} = do
+  undefined
 
 resolveLinked
   :: (MonadInsertError m, MonadFinance m)
@@ -393,20 +419,79 @@ resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale
       v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
       return $ e {eValue = Deferred False v'}
 
-entrySum :: Num v => [Entry a v t] -> v
-entrySum = sum . fmap eValue
+unlinkGetter
+  :: (MonadInsertError m, MonadFinance m)
+  => Vector Rational
+  -> CurID
+  -> LinkedNumGetter
+  -> m (Maybe Rational)
+unlinkGetter from cur LinkedNumGetter {lngIndex, lngScale} = do
+  curMap <- askDBState kmCurrency
+  maybe (return Nothing) (go curMap) $ from V.!? fromIntegral lngIndex
+  where
+    go m = fmap Just . liftExcept . roundPrecisionCur cur m . (* lngScale) . fromRational
+
+balanceFromEntry
+  :: (MonadInsertError m, MonadFinance m)
+  => CurID
+  -> Int
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
+balanceFromEntry = balanceEntry (\a c -> liftInnerS . balanceDeferrred a c)
+
+balanceDeferrred
+  :: AcntID
+  -> CurID
+  -> Deferred Rational
+  -> State EntryBals (Rational, Maybe DBDeferred)
+balanceDeferrred acntID curID (Deferred toBal v) = do
+  newval <- findBalance acntID curID toBal v
+  return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
+
+balanceToEntry
+  :: (MonadInsertError m, MonadFinance m)
+  => Vector Rational
+  -> Day
+  -> CurID
+  -> Int
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
+balanceToEntry from day = balanceEntry go
+  where
+    go _ curID (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) = do
+      res <- unlinkGetter from curID g
+      case res of
+        Just v -> return $ (v, Just $ EntryLinked lngIndex lngScale)
+        Nothing -> throwError undefined
+    go acntID curID (LinkDeferred d) = balanceDeferrred acntID curID d
 
 balanceEntry
-  :: CurID
-  -> Entry AcntID (Deferred Rational) TagID
-  -> State EntryBals (Entry AcntID Rational TagID)
-balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do
+  :: (MonadInsertError m, MonadFinance m)
+  => (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred))
+  -> CurID
+  -> Int
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
+balanceEntry f curID index e@Entry {eValue, eAcnt} = do
+  (newVal, deferred) <- lift $ f eAcnt curID eValue
+  return $
+    FullEntry
+      { feEntry = e {eValue = newVal}
+      , feCurrency = curID
+      , feDeferred = deferred
+      , feIndex = index
+      }
+  where
+    key = (eAcnt, curID)
+
+findBalance :: AcntID -> CurID -> Bool -> Rational -> State EntryBals Rational
+findBalance acnt cur toBal v = do
   curBal <- gets (M.findWithDefault 0 key)
   let newVal = if toBal then v - curBal else v
   modify (mapAdd_ key newVal)
-  return $ e {eValue = newVal}
+  return newVal
   where
-    key = (eAcnt, curID)
+    key = (acnt, cur)
 
 -- -- reimplementation from future version :/
 -- mapAccumM
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 6ea5506..8a73112 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -43,6 +43,7 @@ TransactionR sql=transactions
     commit CommitRId OnDeleteCascade
     date Day
     description T.Text
+    deferred Bool
     deriving Show Eq
 EntryR sql=entries
     transaction TransactionRId OnDeleteCascade
@@ -50,6 +51,9 @@ EntryR sql=entries
     account AccountRId OnDeleteCascade
     memo T.Text
     value Rational
+    index Int
+    deferred_value (Maybe Rational)
+    deferred_link (Maybe Int)
     deriving Show Eq
 TagRelationR sql=tag_relations
     entry EntryRId OnDeleteCascade
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index a5f520c..aeb8c3a 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -61,8 +61,12 @@ type CurrencyM = Reader CurrencyMap
 
 -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
 
+data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
+
 data FullEntry a c t = FullEntry
   { feCurrency :: !c
+  , feIndex :: !Int
+  , feDeferred :: !(Maybe DBDeferred)
   , feEntry :: !(Entry a Rational t)
   }
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 0824b50..f52b76b 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -318,6 +318,7 @@ toTx
     }
   r@TxRecord {trAmount, trDate, trDesc} = do
     combineError curRes subRes $ \(cur, f, t, v) ss ->
+      -- TODO might be more efficient to set rebalance flag when balancing
       Tx
         { txDate = trDate
         , txDescr = trDesc
@@ -343,6 +344,18 @@ toTx
         combineError3 fromRes toRes totRes (cur,,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
+-- anyDeferred :: DeferredEntrySet -> Bool
+-- anyDeferred
+--   EntrySet
+--     { esFrom = HalfEntrySet {hesOther = fs}
+--     , esTo = HalfEntrySet {hesOther = ts}
+--     } =
+--     any checkFrom fs || any checkTo ts
+--     where
+--       checkFrom Entry {eValue = (Deferred True _)} = True
+--       checkFrom _ = False
+--       checkTo = undefined
+
 resolveSubGetter
   :: TxRecord
   -> TxSubGetter

From 05928087b294300cab549067b4cba398c1b5a031 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 24 Jun 2023 17:32:43 -0400
Subject: [PATCH 26/59] WIP add logic for updating entries and summing read
 only entries

---
 lib/Internal/Database.hs   |  13 ++
 lib/Internal/History.hs    | 324 ++++++++++++++++++++-----------------
 lib/Internal/Types/Main.hs |  38 ++++-
 lib/Internal/Utils.hs      |   9 +-
 4 files changed, 235 insertions(+), 149 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 6457541..a609fbf 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -8,6 +8,7 @@ module Internal.Database
   , flattenAcntRoot
   , paths2IDs
   , mkPool
+  , whenHash0
   , whenHash
   , whenHash_
   , insertEntry
@@ -380,6 +381,18 @@ whenHash t o def f = do
   hs <- askDBState kmNewCommits
   if h `elem` hs then f =<< insert (CommitR h t) else return def
 
+whenHash0
+  :: (Hashable a, MonadFinance m)
+  => ConfigType
+  -> a
+  -> b
+  -> (CommitR -> m b)
+  -> m b
+whenHash0 t o def f = do
+  let h = hash o
+  hs <- askDBState kmNewCommits
+  if h `elem` hs then f (CommitR h t) else return def
+
 whenHash_
   :: (Hashable a, MonadFinance m)
   => ConfigType
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index c53a02d..1856e21 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -38,21 +38,21 @@ import qualified RIO.Vector as V
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => HistTransfer
-  -> m (Maybe (CommitR, [DeferredTx]))
+  -> m [DeferredTx CommitR]
 readHistTransfer
   m@Transfer
     { transFrom = from
     , transTo = to
     , transCurrency = u
     , transAmounts = amts
-    } = do
-    whenHash_ CTManual m $ do
+    } =
+    whenHash0 CTManual m [] $ \c -> do
       bounds <- askDBState kmStatementInterval
       let precRes = lookupCurrencyPrec u
       let go Amount {amtWhen, amtValue, amtDesc} = do
             let dayRes = liftExcept $ expandDatePat bounds amtWhen
             (days, precision) <- combineError dayRes precRes (,)
-            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
+            let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc
             return $ fmap tx days
       concat <$> mapErrors go amts
 
@@ -61,15 +61,20 @@ groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
 
+groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
+groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Maybe (CommitR, [DeferredTx]))
-readHistStmt root i = whenHash_ CTImport i $ do
+  -> m [DeferredTx CommitR]
+readHistStmt root i = whenHash0 CTImport i [] $ \c -> do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
-  return $ filter (inDaySpan bounds . txDate) bs
+  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
 
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
@@ -79,11 +84,11 @@ splitHistory = partitionEithers . fmap go
 
 insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [(CommitR, [DeferredTx])]
+  => [DeferredTx CommitR]
   -> m ()
 insertHistory hs = do
-  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
-  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
+  bs <- balanceTxs hs
+  forM_ (groupWith txCommit bs) $ \(c, ts) -> do
     ck <- insert c
     mapM_ (insertTx ck) ts
 
@@ -92,17 +97,19 @@ insertHistory hs = do
 
 -- TODO tags here?
 txPair
-  :: Day
+  :: CommitR
+  -> Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> DeferredTx
-txPair day from to cur val desc =
+  -> DeferredTx CommitR
+txPair commit day from to cur val desc =
   Tx
     { txDescr = desc
     , txDate = day
+    , txCommit = commit
     , txEntries =
         [ EntrySet
             { esTotalValue = -val
@@ -121,20 +128,21 @@ txPair day from to cur val desc =
         , eTags = []
         }
 
-resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
-resolveTx t@Tx {txEntries = ss} =
-  (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
+-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
+-- resolveTx t@Tx {txEntries = ss} =
+--   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
+insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m ()
 insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
-  k <- insert $ TransactionR c d e
+  let anyDeferred = any (isJust . feDeferred) ss
+  k <- insert $ TransactionR c d e anyDeferred
   mapM_ (insertEntry k) ss
 
 --------------------------------------------------------------------------------
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
@@ -182,7 +190,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
 
 -- TODO need to somehow balance temporally here (like I do in the budget for
 -- directives that "pay off" a balance)
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
@@ -243,7 +251,7 @@ zipperSlice f x = go
 zipperMatch
   :: Unzipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -259,7 +267,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
 zipperMatch'
   :: Zipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -276,7 +284,7 @@ matchDec m = case spTimes m of
   Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -286,13 +294,13 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
   return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -313,7 +321,7 @@ matchDates ms = go ([], [], initZipper ms)
           go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -332,25 +340,96 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [(CommitR, DeferredTx)]
-  -> m [(CommitR, KeyTx)]
-balanceTxs ts = do
-  keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty
-  return $ zip cs keyts
+  => [EntryBin]
+  -> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
+balanceTxs es =
+  (first concat . partitionEithers . catMaybes)
+    <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
   where
-    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
-    go t@Tx {txEntries, txDate} =
-      (\es -> t {txEntries = concat es}) <$> mapM (balanceEntrySet txDate) txEntries
+    go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
+      modify $ mapAdd_ (reAcnt, reCurrency) reValue
+      return Nothing
+    go (ToInsert (t@Tx {txEntries, txDate})) =
+      (\es -> Just $ Right $ t {txEntries = concat es})
+        <$> mapM (balanceEntrySet txDate) txEntries
 
-type EntryBals = M.Map (AcntID, CurID) Rational
+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
+  = UEReadOnly (UpdateEntry () Rational)
+  | UEBlank (UpdateEntry EntryRId Rational)
+  | UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
+
+rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
+rebalanceEntrySet
+  UpdateEntrySet
+    { utFrom0
+    , utTo0
+    , utPairs
+    , utFromUnk
+    , utToUnk
+    , utFromRO
+    , utToRO
+    , utCurrency
+    , utTotalValue
+    } =
+    do
+      let fs =
+            L.sortOn index $
+              (UEReadOnly <$> utFromRO)
+                ++ (UEBlank <$> utFromUnk)
+                ++ (UEPaired <$> utPairs)
+      fs' <- mapM goFrom fs
+      let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
+      let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
+      let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
+      (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
+      let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
+      return $ f0 : fs'' ++ t0 : tsUnk
+    where
+      project f _ _ (UEReadOnly e) = f e
+      project _ f _ (UEBlank e) = f e
+      project _ _ f (UEPaired p) = f p
+      index = project ueIndex ueIndex (ueIndex . fst)
+      value = project ueValue ueValue (ueValue . fst)
+      flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
+      -- TODO the following is wetter than the average groupie
+      goFrom (UEReadOnly e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
+        return $ UEReadOnly e
+      goFrom (UEBlank e) = do
+        let key = (ueAcnt e, utCurrency)
+        curBal <- gets (M.findWithDefault 0 key)
+        let newVal = ueValue e - curBal
+        modify $ mapAdd_ key newVal
+        return $ UEBlank $ e {ueValue = newVal}
+      goFrom (UEPaired (e0, e1)) = do
+        let key = (ueAcnt e0, utCurrency)
+        curBal <- gets (M.findWithDefault 0 key)
+        let newVal = ueValue e0 - curBal
+        modify $ mapAdd_ key newVal
+        return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
+      goTo (Left e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
+        return $ Left e
+      goTo (Right e) = do
+        let key = (ueAcnt e, utCurrency)
+        curBal <- gets (M.findWithDefault 0 key)
+        let newVal = ueValue e - curBal
+        modify $ mapAdd_ key newVal
+        return $ Right $ e {ueValue = newVal}
 
--- TODO might be faster to also do all the key stuff here since currency
--- will be looked up for every entry rather then the entire entry set
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
   => Day
   -> DeferredEntrySet
-  -> StateT EntryBals m [BalEntry]
+  -> StateT EntryBals m [KeyEntry]
 balanceEntrySet
   day
   EntrySet
@@ -360,123 +439,82 @@ balanceEntrySet
     , esTotalValue
     } =
     do
-      fs' <- doEntries fs esTotalValue f0
-      -- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs'
-      let fv = V.fromList $ fmap eValue fs'
-      let (lts, dts) = partitionEithers $ splitLinked <$> ts
-      lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
-      ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
-      -- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts'
-      return $ fs' -- ++ ts''
-    where
-      doEntries es tot e0 = do
-        es' <- liftInnerS $ mapM (uncurry (balanceEntry esCurrency)) $ zip [1 ..] es
-        let val0 = tot - entrySum es'
-        modify $ mapAdd_ (eAcnt e0, esCurrency) val0
-        return $ e0 {eValue = val0} : es'
-      doEntriesTo es tot e0 = do
-        es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
-        let val0 = tot - entrySum es'
-        modify $ mapAdd_ (eAcnt e0, esCurrency) val0
-        return $ e0 {eValue = val0} : es'
-      toFullDebit i e target =
-        FullEntry
-          { feEntry = e
-          , feCurrency = esCurrency
-          , feIndex = i
-          , feDeferred = EntryBalance target
-          }
-      splitLinked e@Entry {eValue} = case eValue of
-        LinkIndex l -> Left e {eValue = l}
-        LinkDeferred d -> Right e {eValue = d}
-      entrySum = sum . fmap (eValue . feEntry)
+      -- get currency first and quit immediately on exception since everything
+      -- downstream depends on this
+      (curID, precision) <- lookupCurrency esCurrency
 
+      -- resolve accounts and balance debit entries since we need an array
+      -- of debit entries for linked credit entries later
+      let balFromEntry = balanceEntry (balanceDeferred curID) curID
+      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
+      let fv = V.fromList $ fmap (eValue . feEntry) fs'
+
+      -- finally resolve credit entries
+      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+      ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
+      return $ fs' ++ ts'
+
+doEntries
+  :: (MonadInsertError m, MonadFinance m)
+  => (Int -> Entry AcntID v TagID -> State EntryBals (FullEntry AccountRId CurrencyRId TagID))
+  -> CurrencyRId
+  -> Rational
+  -> Entry AcntID () TagID
+  -> [Entry AcntID v TagID]
+  -> NonEmpty Int
+  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagID]
+doEntries f curID tot e es (i0 :| iN) = do
+  es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
+  let val0 = tot - entrySum es'
+  e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
+  return $ e' : es'
+  where
+    entrySum = sum . fmap (eValue . feEntry)
+
+liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
 
-resolveCreditEntry
-  :: (MonadInsertError m, MonadFinance m)
-  => Vector Rational
-  -> CurID
-  -> Day
-  -> Int
-  -> Entry AcntID LinkedNumGetter TagID
-  -> m (FullEntry AcntID CurID TagID)
-resolveCreditEntry from cur day index e@Entry {eValue} = do
-  undefined
-
-resolveLinked
-  :: (MonadInsertError m, MonadFinance m)
-  => Vector Rational
-  -> CurID
-  -> Day
-  -> Entry AcntID LinkedNumGetter TagID
-  -> m (Entry AcntID (Deferred Rational) TagID)
-resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
-  curMap <- askDBState kmCurrency
-  case from V.!? fromIntegral lngIndex of
-    Nothing -> throwError $ InsertException [IndexError e day]
-    Just v -> do
-      v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
-      return $ e {eValue = Deferred False v'}
-
-unlinkGetter
-  :: (MonadInsertError m, MonadFinance m)
-  => Vector Rational
-  -> CurID
-  -> LinkedNumGetter
-  -> m (Maybe Rational)
-unlinkGetter from cur LinkedNumGetter {lngIndex, lngScale} = do
-  curMap <- askDBState kmCurrency
-  maybe (return Nothing) (go curMap) $ from V.!? fromIntegral lngIndex
+balanceLinked
+  :: Vector Rational
+  -> CurrencyRId
+  -> Natural
+  -> AccountRId
+  -> LinkDeferred Rational
+  -> StateT EntryBals Identity (Rational, Maybe DBDeferred)
+balanceLinked from curID precision acntID lg = case lg of
+  (LinkIndex g@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)
+      Nothing -> throwError undefined
+  (LinkDeferred d) -> balanceDeferred curID acntID d
   where
-    go m = fmap Just . liftExcept . roundPrecisionCur cur m . (* lngScale) . fromRational
+    go s = roundPrecision precision . (* s) . fromRational
 
-balanceFromEntry
-  :: (MonadInsertError m, MonadFinance m)
-  => CurID
-  -> Int
-  -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
-balanceFromEntry = balanceEntry (\a c -> liftInnerS . balanceDeferrred a c)
-
-balanceDeferrred
-  :: AcntID
-  -> CurID
+balanceDeferred
+  :: CurrencyRId
+  -> AccountRId
   -> Deferred Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferrred acntID curID (Deferred toBal v) = do
+balanceDeferred curID acntID (Deferred toBal v) = do
   newval <- findBalance acntID curID toBal v
   return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
 
-balanceToEntry
-  :: (MonadInsertError m, MonadFinance m)
-  => Vector Rational
-  -> Day
-  -> CurID
-  -> Int
-  -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
-balanceToEntry from day = balanceEntry go
-  where
-    go _ curID (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) = do
-      res <- unlinkGetter from curID g
-      case res of
-        Just v -> return $ (v, Just $ EntryLinked lngIndex lngScale)
-        Nothing -> throwError undefined
-    go acntID curID (LinkDeferred d) = balanceDeferrred acntID curID d
-
 balanceEntry
   :: (MonadInsertError m, MonadFinance m)
-  => (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred))
-  -> CurID
+  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  -> CurrencyRId
   -> Int
   -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AcntID CurID TagID)
+  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID)
 balanceEntry f curID index e@Entry {eValue, eAcnt} = do
-  (newVal, deferred) <- lift $ f eAcnt curID eValue
+  (acntID, sign, _) <- lookupAccount eAcnt
+  let s = fromIntegral $ sign2Int sign
+  (newVal, deferred) <- f acntID eValue
+  modify (mapAdd_ (acntID, curID) newVal)
   return $
     FullEntry
-      { feEntry = e {eValue = newVal}
+      { feEntry = e {eValue = s * newVal, eAcnt = acntID}
       , feCurrency = curID
       , feDeferred = deferred
       , feIndex = index
@@ -484,14 +522,10 @@ balanceEntry f curID index e@Entry {eValue, eAcnt} = do
   where
     key = (eAcnt, curID)
 
-findBalance :: AcntID -> CurID -> Bool -> Rational -> State EntryBals Rational
+findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
 findBalance acnt cur toBal v = do
-  curBal <- gets (M.findWithDefault 0 key)
-  let newVal = if toBal then v - curBal else v
-  modify (mapAdd_ key newVal)
-  return newVal
-  where
-    key = (acnt, cur)
+  curBal <- gets (M.findWithDefault 0 (acnt, cur))
+  return $ if toBal then v - curBal else v
 
 -- -- reimplementation from future version :/
 -- mapAccumM
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index aeb8c3a..d668b26 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -63,6 +63,40 @@ type CurrencyM = Reader CurrencyMap
 
 data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
 
+data ReadEntry = ReadEntry
+  { reCurrency :: !CurrencyRId
+  , reAcnt :: !AccountRId
+  , reValue :: !Rational
+  , reDate :: !Day
+  }
+
+data UpdateEntry i v = UpdateEntry
+  { ueID :: !i
+  , ueAcnt :: !AccountRId
+  , ueValue :: !v
+  , ueIndex :: !Int -- TODO this isn't needed for primary entries
+  }
+
+data UpdateEntrySet = UpdateEntrySet
+  { utFrom0 :: !(UpdateEntry EntryRId ())
+  , utTo0 :: !(UpdateEntry EntryRId ())
+  , utPairs :: ![(UpdateEntry EntryRId Rational, UpdateEntry EntryRId ())]
+  , -- for these two, the Rational number is the balance target (not the
+    -- value of the account)
+    utFromUnk :: ![UpdateEntry EntryRId Rational]
+  , utToUnk :: ![UpdateEntry EntryRId Rational]
+  , utFromRO :: ![UpdateEntry () Rational]
+  , utToRO :: ![UpdateEntry () Rational]
+  , utCurrency :: !CurrencyRId
+  , utDate :: !Day
+  , utTotalValue :: !Rational
+  }
+
+data EntryBin
+  = ToUpdate UpdateEntrySet
+  | ToRead ReadEntry
+  | ToInsert (DeferredTx CommitR)
+
 data FullEntry a c t = FullEntry
   { feCurrency :: !c
   , feIndex :: !Int
@@ -131,6 +165,7 @@ data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 data AcntSign = Credit | Debit
   deriving (Show)
 
+-- TODO debit should be negative
 sign2Int :: AcntSign -> Int
 sign2Int Debit = 1
 sign2Int Credit = 1
@@ -154,10 +189,11 @@ data EntrySet a c t v = EntrySet
   , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
   }
 
-data Tx e = Tx
+data Tx e c = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
   , txEntries :: !e
+  , txCommit :: !c
   }
   deriving (Generic)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index f52b76b..e64a86e 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -49,9 +49,11 @@ module Internal.Utils
   , valMatches
   , roundPrecision
   , roundPrecisionCur
+  , lookupAccount
   , lookupAccountKey
   , lookupAccountSign
   , lookupAccountType
+  , lookupCurrency
   , lookupCurrencyKey
   , lookupCurrencyPrec
   , lookupTag
@@ -290,7 +292,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx)
+matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -307,7 +309,7 @@ matches
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
       convert tg = MatchPass <$> toTx tg r
 
-toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
+toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ())
 toTx
   TxGetter
     { tgFrom
@@ -322,6 +324,7 @@ toTx
       Tx
         { txDate = trDate
         , txDescr = trDesc
+        , txCommit = ()
         , txEntries =
             EntrySet
               { esTotalValue = v
@@ -1090,7 +1093,7 @@ lookupAccountSign = fmap sndOf3 . lookupAccount
 lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap thdOf3 . lookupAccount
 
-lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
+lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural)
 lookupCurrency = lookupFinance CurField kmCurrency
 
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId

From fc4da967be545a8dce0460f6c72ee3ad1ac4bbdd Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 25 Jun 2023 14:26:35 -0400
Subject: [PATCH 27/59] WIP read updates from database

---
 lib/Internal/Database.hs   | 162 ++++++++++++++++++++++++++++++++++++-
 lib/Internal/History.hs    |  32 +++-----
 lib/Internal/Types/Main.hs |   7 +-
 lib/Internal/Utils.hs      |  12 +++
 4 files changed, 188 insertions(+), 25 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index a609fbf..d19f207 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -11,8 +11,10 @@ module Internal.Database
   , whenHash0
   , whenHash
   , whenHash_
+  , eitherHash
   , insertEntry
   , resolveEntry
+  , readUpdates
   )
 where
 
@@ -20,7 +22,7 @@ import Conduit
 import Control.Monad.Except
 import Control.Monad.Logger
 import Data.Hashable
-import Database.Esqueleto.Experimental ((==.), (^.))
+import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
@@ -43,6 +45,7 @@ import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as N
 import qualified RIO.Text as T
+import qualified RIO.Vector as V
 
 runDB
   :: MonadUnliftIO m
@@ -393,6 +396,19 @@ whenHash0 t o def f = do
   hs <- askDBState kmNewCommits
   if h `elem` hs then f (CommitR h t) else return def
 
+eitherHash
+  :: (Hashable a, MonadFinance m)
+  => ConfigType
+  -> a
+  -> (CommitR -> m b)
+  -> (CommitR -> m c)
+  -> m (Either b c)
+eitherHash t o f g = do
+  let h = hash o
+  let c = CommitR h t
+  hs <- askDBState kmNewCommits
+  if h `elem` hs then Left <$> f c else Right <$> g c
+
 whenHash_
   :: (Hashable a, MonadFinance m)
   => ConfigType
@@ -438,3 +454,147 @@ resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency}
         { feCurrency = cid
         , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
         }
+
+readUpdates
+  :: (MonadInsertError m, MonadSqlQuery m)
+  => [Int]
+  -> m [Either ReadEntry UpdateEntrySet]
+readUpdates hashes = do
+  xs <- selectE $ do
+    (commits :& txs :& entries) <-
+      E.from
+        $ E.table @CommitR
+          `E.innerJoin` E.table @TransactionR
+        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
+          `E.innerJoin` E.table @EntryR
+        `E.on` (\(_ :& t :& e) -> t ^. TransactionRId ==. e ^. EntryRTransaction)
+    E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
+    return
+      ( txs ^. TransactionRDeferred
+      , txs ^. TransactionRDate
+      , entries
+      )
+  let (toUpdate, toRead) =
+        bimap unpack (fmap makeRE . unpack) $
+          L.partition (\(d, _, _) -> E.unValue d) xs
+  toUpdate' <-
+    liftExcept $
+      mapErrors makeUES $
+        second (fmap snd) <$> groupWith uGroup toUpdate
+  return $ fmap Left toRead ++ fmap Right toUpdate'
+  where
+    unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
+    uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
+    makeUES ((day, cur, _), es) = do
+      let (froms, tos) =
+            L.partition ((< 0) . entryRIndex . snd) $
+              L.sortOn (entryRIndex . snd) es
+      let tot = sum $ fmap (entryRValue . snd) froms
+      (from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
+      (to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
+      return
+        UpdateEntrySet
+          { utDate = day
+          , utCurrency = cur
+          , utFrom0 = from0
+          , utTo0 = to0
+          , utFromRO = fromRO
+          , utToRO = toRO
+          , utToUnkLink0 = toLink0
+          , utPairs = toLinkN
+          , utFromUnk = fromUnk
+          , utToUnk = toUnk
+          , utTotalValue = tot
+          }
+    makeRE (d, (_, e)) =
+      ReadEntry
+        { reDate = d
+        , reCurrency = entryRCurrency e
+        , reAcnt = entryRAccount e
+        , reValue = entryRValue e
+        }
+
+splitFrom
+  :: [(EntryRId, EntryR)]
+  -> InsertExcept
+      ( UpdateEntry EntryRId ()
+      , [UpdateEntry () Rational]
+      , [UpdateEntry EntryRId Rational]
+      , Vector (Maybe (UpdateEntry EntryRId Rational))
+      )
+splitFrom from = do
+  -- ASSUME entries are sorted by index
+  (primary, rest) <- case from of
+    ((i, e) : xs) -> return (makeUnkUE i e, xs)
+    _ -> throwError $ InsertException undefined
+  let rest' = fmap splitDeferredValue rest
+  let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
+  let (ro, toBal) = partitionEithers rest'
+  return (primary, ro, toBal, idxVec)
+
+splitTo
+  :: Vector (Maybe (UpdateEntry EntryRId Rational))
+  -> [(EntryRId, EntryR)]
+  -> InsertExcept
+      ( UpdateEntry EntryRId ()
+      , [UpdateEntry () Rational]
+      , [UpdateEntry EntryRId Rational]
+      , [UpdateEntry EntryRId ()]
+      , [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
+      )
+splitTo froms tos = do
+  -- How to split the credit side of the database transaction in 1024 easy
+  -- steps:
+  --
+  -- 1. ASSUME the entries are sorted by index. Isolate the first as the
+  --    primary and puke in user's face if list is empty (which it should never
+  --    be)
+  (primary, rest) <- case tos of
+    ((i, e) : xs) -> return (makeUnkUE i e, xs)
+    _ -> throwError $ InsertException undefined
+
+  -- 1. Split the entries based on if they have a link
+  let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
+
+  -- 2. Split unlinked based on if they have a balance target
+  let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
+
+  -- 3. Split paired entries by link == 0 (which are special) or link > 0
+  let (paired0, pairedN) =
+        bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
+          L.partition ((== 0) . fst) linked
+
+  -- 4. Group linked entries (which now have links > 0) according to the debit
+  --    entry to which they are linked. If the debit entry cannot be found or
+  --    if the linked entry has no scale, blow up in user's face. If the
+  --    debit entry is read-only (signified by Nothing in the 'from' array)
+  --    then consider the linked entry as another credit read-only entry
+  (pairedUnk, pairedRO) <- partitionEithers <$> mapErrors splitPaired pairedN
+
+  return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
+  where
+    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
+    splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
+      Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
+      Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
+      Nothing -> throwError $ InsertException undefined
+    makeLinkUnk (k, e) =
+      maybe
+        (throwError $ InsertException undefined)
+        (return . makeUE k e)
+        $ entryRDeferred_value e
+
+splitDeferredValue
+  :: (EntryRId, EntryR)
+  -> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
+splitDeferredValue (k, e) =
+  maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value e
+
+makeUE :: i -> EntryR -> v -> UpdateEntry i v
+makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
+
+makeRoUE :: EntryR -> UpdateEntry () Rational
+makeRoUE e = makeUE () e (entryRValue e)
+
+makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
+makeUnkUE k e = makeUE k e ()
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 1856e21..4f60d17 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -56,22 +56,12 @@ readHistTransfer
             return $ fmap tx days
       concat <$> mapErrors go amts
 
-groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
-groupKey f = fmap go . NE.groupAllWith (f . fst)
-  where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
-
-groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
-groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
-  where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
-
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m [DeferredTx CommitR]
-readHistStmt root i = whenHash0 CTImport i [] $ \c -> do
+  -> m (Either CommitR [DeferredTx 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 = c}) bs
@@ -84,11 +74,11 @@ splitHistory = partitionEithers . fmap go
 
 insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [DeferredTx CommitR]
+  => [EntryBin]
   -> m ()
 insertHistory hs = do
-  bs <- balanceTxs hs
-  forM_ (groupWith txCommit bs) $ \(c, ts) -> do
+  (toUpdate, toInsert) <- balanceTxs hs
+  forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do
     ck <- insert c
     mapM_ (insertTx ck) ts
 
@@ -456,13 +446,13 @@ balanceEntrySet
 
 doEntries
   :: (MonadInsertError m, MonadFinance m)
-  => (Int -> Entry AcntID v TagID -> State EntryBals (FullEntry AccountRId CurrencyRId TagID))
+  => (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () TagID
-  -> [Entry AcntID v TagID]
+  -> Entry AcntID () t
+  -> [Entry AcntID v t]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagID]
+  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId t]
 doEntries f curID tot e es (i0 :| iN) = do
   es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
   let val0 = tot - entrySum es'
@@ -505,8 +495,8 @@ balanceEntry
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
   -> Int
-  -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID)
+  -> Entry AcntID v t
+  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId t)
 balanceEntry f curID index e@Entry {eValue, eAcnt} = do
   (acntID, sign, _) <- lookupAccount eAcnt
   let s = fromIntegral $ sign2Int sign
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index d668b26..435a2b7 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -80,11 +80,12 @@ data UpdateEntry i v = UpdateEntry
 data UpdateEntrySet = UpdateEntrySet
   { utFrom0 :: !(UpdateEntry EntryRId ())
   , utTo0 :: !(UpdateEntry EntryRId ())
-  , utPairs :: ![(UpdateEntry EntryRId Rational, UpdateEntry EntryRId ())]
-  , -- for these two, the Rational number is the balance target (not the
+  , -- for these next three, the Rational number is the balance target (not the
     -- value of the account)
-    utFromUnk :: ![UpdateEntry EntryRId Rational]
+    utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
+  , utFromUnk :: ![UpdateEntry EntryRId Rational]
   , utToUnk :: ![UpdateEntry EntryRId Rational]
+  , utToUnkLink0 :: ![UpdateEntry EntryRId ()]
   , utFromRO :: ![UpdateEntry () Rational]
   , utToRO :: ![UpdateEntry () Rational]
   , utCurrency :: !CurrencyRId
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index e64a86e..656436f 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -58,6 +58,8 @@ module Internal.Utils
   , lookupCurrencyPrec
   , lookupTag
   , mapAdd_
+  , groupKey
+  , groupWith
   )
 where
 
@@ -1007,6 +1009,16 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 --   where
 --     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
 
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey f = fmap go . NE.groupAllWith (f . fst)
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
+groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
+groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
 mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 

From 7a44aeb5dbea725c1017e48c397f0ad2bd816516 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 25 Jun 2023 21:16:47 -0400
Subject: [PATCH 28/59] WIP use newtypes to keep update balancer sane

---
 lib/Internal/Database.hs   | 42 ++++++++-----------
 lib/Internal/History.hs    | 84 +++++++++++++++++++++++---------------
 lib/Internal/Types/Main.hs | 39 +++++++++++++-----
 3 files changed, 99 insertions(+), 66 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index d19f207..889c081 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -516,12 +516,7 @@ readUpdates hashes = do
 
 splitFrom
   :: [(EntryRId, EntryR)]
-  -> InsertExcept
-      ( UpdateEntry EntryRId ()
-      , [UpdateEntry () Rational]
-      , [UpdateEntry EntryRId Rational]
-      , Vector (Maybe (UpdateEntry EntryRId Rational))
-      )
+  -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
 splitFrom from = do
   -- ASSUME entries are sorted by index
   (primary, rest) <- case from of
@@ -533,14 +528,14 @@ splitFrom from = do
   return (primary, ro, toBal, idxVec)
 
 splitTo
-  :: Vector (Maybe (UpdateEntry EntryRId Rational))
+  :: Vector (Maybe UEBalance)
   -> [(EntryRId, EntryR)]
   -> InsertExcept
-      ( UpdateEntry EntryRId ()
-      , [UpdateEntry () Rational]
-      , [UpdateEntry EntryRId Rational]
-      , [UpdateEntry EntryRId ()]
-      , [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
+      ( UEBlank
+      , [UE_RO]
+      , [UEBalance]
+      , [UELink]
+      , [(UEBalance, [UELink])]
       )
 splitTo froms tos = do
   -- How to split the credit side of the database transaction in 1024 easy
@@ -560,18 +555,18 @@ splitTo froms tos = do
   let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
 
   -- 3. Split paired entries by link == 0 (which are special) or link > 0
-  let (paired0, pairedN) =
-        bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
-          L.partition ((== 0) . fst) linked
+  let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
+  let paired0Res = mapErrors (makeLinkUnk . snd) paired0
 
   -- 4. Group linked entries (which now have links > 0) according to the debit
   --    entry to which they are linked. If the debit entry cannot be found or
   --    if the linked entry has no scale, blow up in user's face. If the
   --    debit entry is read-only (signified by Nothing in the 'from' array)
   --    then consider the linked entry as another credit read-only entry
-  (pairedUnk, pairedRO) <- partitionEithers <$> mapErrors splitPaired pairedN
+  let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
 
-  return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
+  combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
+    (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
   where
     splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
     splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
@@ -581,20 +576,19 @@ splitTo froms tos = do
     makeLinkUnk (k, e) =
       maybe
         (throwError $ InsertException undefined)
-        (return . makeUE k e)
+        (return . makeUE k e . LinkScale)
         $ entryRDeferred_value e
 
-splitDeferredValue
-  :: (EntryRId, EntryR)
-  -> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
+splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
 splitDeferredValue (k, e) =
-  maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value e
+  maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $
+    entryRDeferred_value e
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
 
-makeRoUE :: EntryR -> UpdateEntry () Rational
-makeRoUE e = makeUE () e (entryRValue e)
+makeRoUE :: EntryR -> UpdateEntry () EntryValue
+makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 4f60d17..f1291ec 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -331,7 +331,7 @@ matchNonDates ms = go ([], [], initZipper ms)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
-  -> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
+  -> m ([UEBalanced], [KeyTx CommitR])
 balanceTxs es =
   (first concat . partitionEithers . catMaybes)
     <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
@@ -352,11 +352,11 @@ binDate (ToInsert (Tx {txDate})) = txDate
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
 data UpdateEntryType a
-  = UEReadOnly (UpdateEntry () Rational)
-  | UEBlank (UpdateEntry EntryRId Rational)
-  | UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
+  = UET_ReadOnly UE_RO
+  | UET_Balance UEBalance
+  | UET_Linked a
 
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
+rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceEntrySet
   UpdateEntrySet
     { utFrom0
@@ -367,53 +367,73 @@ rebalanceEntrySet
     , utFromRO
     , utToRO
     , utCurrency
+    , utToUnkLink0
     , utTotalValue
     } =
     do
       let fs =
             L.sortOn index $
-              (UEReadOnly <$> utFromRO)
-                ++ (UEBlank <$> utFromUnk)
-                ++ (UEPaired <$> utPairs)
+              (UET_ReadOnly <$> utFromRO)
+                ++ (UET_Balance <$> utFromUnk)
+                ++ (UET_Linked <$> utPairs)
       fs' <- mapM goFrom fs
-      let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
-      let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
-      let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
+      let f0val = utTotalValue - (sum $ fmap value fs')
+      let f0 = utFrom0 {ueValue = EntryValue f0val}
+      let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
+      let ts =
+            (UET_Linked <$> tpairs)
+              ++ (UET_Balance <$> utToUnk)
+              ++ (UET_ReadOnly <$> utToRO)
+      let tsLink0 = fmap (\e -> e {ueValue = -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
-      let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
-      return $ f0 : fs'' ++ t0 : tsUnk
+      let t0val =
+            (EntryValue utTotalValue)
+              - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
+      let t0 = utTo0 {ueValue = t0val}
+      return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
     where
-      project f _ _ (UEReadOnly e) = f e
-      project _ f _ (UEBlank e) = f e
-      project _ _ f (UEPaired p) = f p
+      project f _ _ (UET_ReadOnly e) = f e
+      project _ f _ (UET_Balance e) = f e
+      project _ _ f (UET_Linked p) = f p
       index = project ueIndex ueIndex (ueIndex . fst)
-      value = project ueValue ueValue (ueValue . fst)
-      flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
+      value =
+        project
+          (unEntryValue . ueValue)
+          (unBalanceTarget . ueValue)
+          (unBalanceTarget . ueValue . fst)
+      flatten = project (const []) ((: []) . Right) (\(a, bs) -> (Right a) : (Left <$> bs))
       -- TODO the following is wetter than the average groupie
-      goFrom (UEReadOnly e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
-        return $ UEReadOnly e
-      goFrom (UEBlank e) = do
+      goFrom (UET_ReadOnly e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        return $ UET_ReadOnly e
+      goFrom (UET_Balance e) = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e - curBal
+        let newVal = unBalanceTarget (ueValue e) - curBal
         modify $ mapAdd_ key newVal
-        return $ UEBlank $ e {ueValue = newVal}
-      goFrom (UEPaired (e0, e1)) = do
+        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
+      goFrom (UET_Linked (e0, es)) = do
         let key = (ueAcnt e0, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e0 - curBal
+        let newVal = unBalanceTarget (ueValue e0) - curBal
         modify $ mapAdd_ key newVal
-        return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
-      goTo (Left e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
+        return $
+          UET_Linked $
+            ( e0 {ueValue = BalanceTarget newVal}
+            , fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
+            )
+      goTo (UET_ReadOnly e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
         return $ Left e
-      goTo (Right e) = do
+      goTo (UET_Linked e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        return $ Right e
+      goTo (UET_Balance e) = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e - curBal
+        let newVal = unBalanceTarget (ueValue e) - curBal
         modify $ mapAdd_ key newVal
-        return $ Right $ e {ueValue = newVal}
+        return $ Right $ e {ueValue = EntryValue newVal}
 
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 435a2b7..3981583 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -77,17 +77,36 @@ data UpdateEntry i v = UpdateEntry
   , ueIndex :: !Int -- TODO this isn't needed for primary entries
   }
 
+deriving instance Functor (UpdateEntry i)
+
+newtype LinkScale = LinkScale {unLinkScale :: Rational}
+  deriving newtype (Num)
+
+newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+  deriving newtype (Num)
+
+newtype EntryValue = EntryValue {unEntryValue :: Rational}
+  deriving newtype (Num)
+
+type UEBalance = UpdateEntry EntryRId BalanceTarget
+
+type UELink = UpdateEntry EntryRId LinkScale
+
+type UEBlank = UpdateEntry EntryRId ()
+
+type UE_RO = UpdateEntry () EntryValue
+
+type UEBalanced = UpdateEntry EntryRId EntryValue
+
 data UpdateEntrySet = UpdateEntrySet
-  { utFrom0 :: !(UpdateEntry EntryRId ())
-  , utTo0 :: !(UpdateEntry EntryRId ())
-  , -- for these next three, the Rational number is the balance target (not the
-    -- value of the account)
-    utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
-  , utFromUnk :: ![UpdateEntry EntryRId Rational]
-  , utToUnk :: ![UpdateEntry EntryRId Rational]
-  , utToUnkLink0 :: ![UpdateEntry EntryRId ()]
-  , utFromRO :: ![UpdateEntry () Rational]
-  , utToRO :: ![UpdateEntry () Rational]
+  { utFrom0 :: !UEBlank
+  , utTo0 :: !UEBlank
+  , utPairs :: ![(UEBalance, [UELink])]
+  , utFromUnk :: ![UEBalance]
+  , utToUnk :: ![UEBalance]
+  , utToUnkLink0 :: ![UELink]
+  , utFromRO :: ![UE_RO]
+  , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !Rational

From f8669e5a1551a53598ff0a43c31cf549201c466f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 26 Jun 2023 00:10:40 -0400
Subject: [PATCH 29/59] WIP add code to actually insert updates in the db

---
 lib/Internal/History.hs | 87 +++++++++++++++++++++++------------------
 1 file changed, 48 insertions(+), 39 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index f1291ec..6465976 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -9,6 +9,7 @@ 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
@@ -78,9 +79,11 @@ insertHistory
   -> m ()
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
-  forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do
-    ck <- insert c
-    mapM_ (insertTx ck) ts
+  mapM_ updateTx toUpdate
+  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
+    \(c, ts) -> do
+      ck <- insert $ c
+      mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -128,6 +131,9 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
   k <- insert $ TransactionR c d e anyDeferred
   mapM_ (insertEntry k) ss
 
+updateTx :: MonadSqlQuery m => UEBalanced -> m ()
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)]
+
 --------------------------------------------------------------------------------
 -- Statements
 
@@ -334,14 +340,14 @@ balanceTxs
   -> m ([UEBalanced], [KeyTx CommitR])
 balanceTxs es =
   (first concat . partitionEithers . catMaybes)
-    <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
+    <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
   where
-    go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx
+    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 (t@Tx {txEntries, txDate})) =
-      (\es -> Just $ Right $ t {txEntries = concat es})
+      (\es' -> Just $ Right $ t {txEntries = concat es'})
         <$> mapM (balanceEntrySet txDate) txEntries
 
 binDate :: EntryBin -> Day
@@ -372,7 +378,7 @@ rebalanceEntrySet
     } =
     do
       let fs =
-            L.sortOn index $
+            L.sortOn idx $
               (UET_ReadOnly <$> utFromRO)
                 ++ (UET_Balance <$> utFromUnk)
                 ++ (UET_Linked <$> utPairs)
@@ -380,11 +386,12 @@ rebalanceEntrySet
       let f0val = utTotalValue - (sum $ fmap value fs')
       let f0 = utFrom0 {ueValue = EntryValue f0val}
       let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
+      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
       let ts =
-            (UET_Linked <$> tpairs)
-              ++ (UET_Balance <$> utToUnk)
-              ++ (UET_ReadOnly <$> utToRO)
-      let tsLink0 = fmap (\e -> e {ueValue = -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
+            L.sortOn idx2 $
+              (UET_Linked <$> (tpairs ++ tsLink0))
+                ++ (UET_Balance <$> utToUnk)
+                ++ (UET_ReadOnly <$> utToRO)
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
       let t0val =
             (EntryValue utTotalValue)
@@ -395,7 +402,8 @@ rebalanceEntrySet
       project f _ _ (UET_ReadOnly e) = f e
       project _ f _ (UET_Balance e) = f e
       project _ _ f (UET_Linked p) = f p
-      index = project ueIndex ueIndex (ueIndex . fst)
+      idx = project ueIndex ueIndex (ueIndex . fst)
+      idx2 = project ueIndex ueIndex ueIndex
       value =
         project
           (unEntryValue . ueValue)
@@ -455,8 +463,8 @@ balanceEntrySet
 
       -- resolve accounts and balance debit entries since we need an array
       -- of debit entries for linked credit entries later
-      let balFromEntry = balanceEntry (balanceDeferred curID) curID
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
+      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
       let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
       -- finally resolve credit entries
@@ -466,15 +474,15 @@ balanceEntrySet
 
 doEntries
   :: (MonadInsertError m, MonadFinance m)
-  => (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t))
+  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () t
-  -> [Entry AcntID v t]
+  -> Entry AcntID () TagID
+  -> [Entry AcntID v TagID]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId t]
+  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
 doEntries f curID tot e es (i0 :| iN) = do
-  es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
+  es' <- mapM (uncurry f) $ zip iN es
   let val0 = tot - entrySum es'
   e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
   return $ e' : es'
@@ -485,19 +493,20 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
 
 balanceLinked
-  :: Vector Rational
+  :: MonadInsertError m
+  => Vector Rational
   -> CurrencyRId
   -> Natural
   -> AccountRId
   -> LinkDeferred Rational
-  -> StateT EntryBals Identity (Rational, Maybe DBDeferred)
+  -> StateT EntryBals m (Rational, Maybe DBDeferred)
 balanceLinked from curID precision acntID lg = case lg of
-  (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) -> do
+  (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)
       Nothing -> throwError undefined
-  (LinkDeferred d) -> balanceDeferred curID acntID d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
   where
     go s = roundPrecision precision . (* s) . fromRational
 
@@ -515,22 +524,22 @@ balanceEntry
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
   -> Int
-  -> Entry AcntID v t
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId t)
-balanceEntry f curID index e@Entry {eValue, eAcnt} = do
-  (acntID, sign, _) <- lookupAccount eAcnt
-  let s = fromIntegral $ sign2Int sign
-  (newVal, deferred) <- f acntID eValue
-  modify (mapAdd_ (acntID, curID) newVal)
-  return $
-    FullEntry
-      { feEntry = e {eValue = s * newVal, eAcnt = acntID}
-      , feCurrency = curID
-      , feDeferred = deferred
-      , feIndex = index
-      }
-  where
-    key = (eAcnt, curID)
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (FullEntry 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 $
+      FullEntry
+        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
+        , feCurrency = curID
+        , feDeferred = deferred
+        , feIndex = idx
+        }
 
 findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
 findBalance acnt cur toBal v = do

From d617fa52cc99c46198fadc3a9961622d29fd8d84 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 26 Jun 2023 19:04:37 -0400
Subject: [PATCH 30/59] REF clean code

---
 lib/Internal/History.hs | 32 ++++++++++++++++----------------
 1 file changed, 16 insertions(+), 16 deletions(-)

diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 6465976..fcce8ee 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -339,21 +339,21 @@ balanceTxs
   => [EntryBin]
   -> m ([UEBalanced], [KeyTx CommitR])
 balanceTxs es =
-  (first concat . partitionEithers . catMaybes)
+  first concat . partitionEithers . catMaybes
     <$> evalStateT (mapErrors go $ L.sortOn binDate es) 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 (t@Tx {txEntries, txDate})) =
+    go (ToInsert t@Tx {txEntries}) =
       (\es' -> Just $ Right $ t {txEntries = concat es'})
-        <$> mapM (balanceEntrySet txDate) txEntries
+        <$> mapErrors balanceEntrySet txEntries
 
 binDate :: EntryBin -> Day
-binDate (ToUpdate (UpdateEntrySet {utDate})) = utDate
+binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
-binDate (ToInsert (Tx {txDate})) = txDate
+binDate (ToInsert Tx {txDate}) = txDate
 
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
@@ -383,10 +383,10 @@ rebalanceEntrySet
                 ++ (UET_Balance <$> utFromUnk)
                 ++ (UET_Linked <$> utPairs)
       fs' <- mapM goFrom fs
-      let f0val = utTotalValue - (sum $ fmap value fs')
+      let f0val = utTotalValue - sum (fmap value fs')
       let f0 = utFrom0 {ueValue = EntryValue f0val}
       let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
-      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
+      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0
       let ts =
             L.sortOn idx2 $
               (UET_Linked <$> (tpairs ++ tsLink0))
@@ -394,10 +394,10 @@ rebalanceEntrySet
                 ++ (UET_ReadOnly <$> utToRO)
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
       let t0val =
-            (EntryValue utTotalValue)
-              - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
+            EntryValue utTotalValue
+              - sum (fmap ueValue tsRO ++ fmap ueValue tsUnk)
       let t0 = utTo0 {ueValue = t0val}
-      return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
+      return $ (f0 : fmap (fmap (EntryValue . unBalanceTarget)) fs'') ++ (t0 : tsUnk)
     where
       project f _ _ (UET_ReadOnly e) = f e
       project _ f _ (UET_Balance e) = f e
@@ -409,7 +409,7 @@ rebalanceEntrySet
           (unEntryValue . ueValue)
           (unBalanceTarget . ueValue)
           (unBalanceTarget . ueValue . fst)
-      flatten = project (const []) ((: []) . Right) (\(a, bs) -> (Right a) : (Left <$> bs))
+      flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs))
       -- TODO the following is wetter than the average groupie
       goFrom (UET_ReadOnly e) = do
         modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
@@ -426,7 +426,7 @@ rebalanceEntrySet
         let newVal = unBalanceTarget (ueValue e0) - curBal
         modify $ mapAdd_ key newVal
         return $
-          UET_Linked $
+          UET_Linked
             ( e0 {ueValue = BalanceTarget newVal}
             , fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
             )
@@ -445,11 +445,9 @@ rebalanceEntrySet
 
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => Day
-  -> DeferredEntrySet
+  => DeferredEntrySet
   -> StateT EntryBals m [KeyEntry]
 balanceEntrySet
-  day
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -482,7 +480,7 @@ doEntries
   -> NonEmpty Int
   -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
 doEntries f curID tot e es (i0 :| iN) = do
-  es' <- mapM (uncurry f) $ zip iN es
+  es' <- mapErrors (uncurry f) $ zip iN es
   let val0 = tot - entrySum es'
   e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
   return $ e' : es'
@@ -505,6 +503,8 @@ balanceLinked from curID precision acntID lg = case lg of
     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

From cc0699eb4efdc1bfb82f9d8262632bec5cfdd8ff Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 29 Jun 2023 21:32:14 -0400
Subject: [PATCH 31/59] WIP make budget and statement paths use same machinery

---
 dhall/Types.dhall              | 119 +++++++------
 lib/Internal/Budget.hs         |  58 ++++++
 lib/Internal/Database.hs       |  54 +++---
 lib/Internal/History.hs        | 316 ++++++++++++++++++++-------------
 lib/Internal/Types/Database.hs |   6 +-
 lib/Internal/Types/Dhall.hs    |  32 ++--
 lib/Internal/Types/Main.hs     |  83 +++++----
 lib/Internal/Utils.hs          | 198 +++++----------------
 8 files changed, 461 insertions(+), 405 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index c0856d4..d181022 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -402,13 +402,15 @@ let EntryNumGetter =
 
     LookupN: lookup the value from a field
     ConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    AmountN: the value of the 'Amount' column times a scaling factor
     BalanceN: the amount required to make the target account reach a balance
+    PercentN: the amount required to make an account reach a given percentage
     -}
       < LookupN : Text
       | ConstN : Double
       | AmountN : Double
       | BalanceN : Double
+      | PercentN : Double
       >
 
 let LinkedNumGetter =
@@ -679,6 +681,58 @@ let Amount =
       \(v : Type) ->
         { amtWhen : w, amtValue : v, amtDesc : Text }
 
+let Exchange =
+    {-
+    A currency exchange.
+    -}
+      { xFromCur :
+          {-
+          Starting currency of the exchange.
+          -}
+          CurID
+      , xToCur :
+          {-
+          Ending currency of the exchange.
+          -}
+          CurID
+      , xAcnt :
+          {-
+          account in which the exchange will be documented.
+          -}
+          AcntID
+      , xRate :
+          {-
+          The exchange rate between the currencies.
+          -}
+          Double
+      }
+
+let TransferCurrency =
+    {-
+    Means to represent currency in a transcaction; either single fixed currency
+    or two currencies with an exchange rate.
+    -}
+      < NoX : CurID | X : Exchange >
+
+let TransferType =
+    {-
+    The type of a budget transfer.
+
+    BTFixed: Tranfer a fixed amount
+    BTPercent: Transfer a percent of the source account to destination
+    BTTarget: Transfer an amount such that the destination has a given target
+              value
+    -}
+      < TPercent | TBalance | TFixed >
+
+let TransferValue =
+    {-
+    Means to determine the value of a budget transfer.
+    -}
+      { Type = { tvVal : Double, tvType : TransferType }
+      , default.tvType = TransferType.TFixed
+      }
+
 let Transfer =
     {-
     1-1 transaction(s) between two accounts.
@@ -697,7 +751,7 @@ let HistTransfer =
     {-
     A manually specified historical transfer
     -}
-      Transfer AcntID CurID DatePat Double
+      Transfer AcntID CurID DatePat TransferValue.Type
 
 let Statement =
     {-
@@ -734,38 +788,6 @@ let History =
     -}
       < HistTransfer : HistTransfer | HistStatement : Statement >
 
-let Exchange =
-    {-
-    A currency exchange.
-    -}
-      { xFromCur :
-          {-
-          Starting currency of the exchange.
-          -}
-          CurID
-      , xToCur :
-          {-
-          Ending currency of the exchange.
-          -}
-          CurID
-      , xAcnt :
-          {-
-          account in which the exchange will be documented.
-          -}
-          AcntID
-      , xRate :
-          {-
-          The exchange rate between the currencies.
-          -}
-          Double
-      }
-
-let BudgetCurrency =
-    {-
-    A 'currency' in the budget; either a fixed currency or an exchange
-    -}
-      < NoX : CurID | X : Exchange >
-
 let TaggedAcnt =
     {-
     An account with a tag
@@ -1037,17 +1059,6 @@ let TransferMatcher =
         }
       }
 
-let BudgetTransferType =
-    {-
-    The type of a budget transfer.
-
-    BTFixed: Tranfer a fixed amount
-    BTPercent: Transfer a percent of the source account to destination
-    BTTarget: Transfer an amount such that the destination has a given target
-              value
-    -}
-      < BTPercent | BTTarget | BTFixed >
-
 let ShadowTransfer =
     {-
     A transaction analogous to another transfer with given properties.
@@ -1066,7 +1077,7 @@ let ShadowTransfer =
           {-
           Currency of this transfer.
           -}
-          BudgetCurrency
+          TransferCurrency
       , stDesc :
           {-
           Description of this transfer.
@@ -1080,7 +1091,7 @@ let ShadowTransfer =
           specified in other fields of this type.
           -}
           TransferMatcher.Type
-      , stType : BudgetTransferType
+      , stType : TransferType
       , stRatio :
           {-
           Fixed multipler to translate value of matched transfer to this one.
@@ -1088,17 +1099,11 @@ let ShadowTransfer =
           Double
       }
 
-let BudgetTransferValue =
-    {-
-    Means to determine the value of a budget transfer.
-    -}
-      { btVal : Double, btType : BudgetTransferType }
-
 let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+      Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type
 
 let Budget =
     {-
@@ -1168,7 +1173,7 @@ in  { CurID
     , TransferMatcher
     , ShadowTransfer
     , AcntSet
-    , BudgetCurrency
+    , TransferCurrency
     , Exchange
     , TaggedAcnt
     , AccountTree
@@ -1180,8 +1185,8 @@ in  { CurID
     , TaxProgression
     , TaxMethod
     , TaxValue
-    , BudgetTransferValue
-    , BudgetTransferType
+    , TransferValue
+    , TransferType
     , TxGetter
     , TxSubGetter
     , TxHalfGetter
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index ad46f74..672655d 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -59,6 +59,8 @@ insertBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
 
+-- TODO need to systematically make this function match the history version,
+-- which will allow me to use the same balancing algorithm for both
 balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
 balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
   where
@@ -527,8 +529,64 @@ data UnbalancedValue = UnbalancedValue
   }
   deriving (Show)
 
+-- TODO need to make this into the same ish thing as the Tx/EntrySet structs
+-- in the history algorithm, which will entail resolving the budget currency
+-- stuff earlier in the chain, and preloading multiple entries into this thing
+-- before balancing.
 type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
+ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta
+ubt2tx
+  FlatTransfer
+    { ftFrom
+    , ftTo
+    , ftValue
+    , ftWhen
+    , ftDesc
+    , ftMeta
+    , ftCur
+    } =
+    Tx
+      { txDescr = ftDesc
+      , txDate = ftWhen
+      , txEntries = entries ftCur
+      , txCommit = ftMeta
+      }
+    where
+      entries (NoX curid) = [pair curid ftFrom ftTo ftValue]
+      entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
+        let middle = TaggedAcnt xAcnt []
+            p1 = pair xFromCur ftFrom middle ftValue
+            p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
+         in [p1, p2]
+      pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
+        EntrySet
+          { esTotalValue = v
+          , esCurrency = c
+          , esFrom =
+              HalfEntrySet
+                { hesPrimary =
+                    Entry
+                      { eValue = ()
+                      , eComment = ""
+                      , eAcnt = fa
+                      , eTags = fts
+                      }
+                , hesOther = []
+                }
+          , esTo =
+              HalfEntrySet
+                { hesPrimary =
+                    Entry
+                      { eValue = ()
+                      , eComment = ""
+                      , eAcnt = ta
+                      , eTags = tts
+                      }
+                , hesOther = []
+                }
+          }
+
 type BalancedTransfer = FlatTransfer Rational
 
 data FlatTransfer v = FlatTransfer
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 889c081..2598c59 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -193,7 +193,7 @@ currencyMap =
     . fmap
       ( \e ->
           ( currencyRSymbol $ entityVal e
-          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
+          , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e
           )
       )
 
@@ -424,24 +424,25 @@ whenHash_ t o f = do
 insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
 insertEntry
   t
-  FullEntry
+  InsertEntry
     { feEntry = Entry {eValue, eTags, eAcnt, eComment}
     , feCurrency
     , feIndex
     , feDeferred
     } =
     do
-      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex defval deflink
+      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
       mapM_ (insert_ . TagRelationR k) eTags
       return k
     where
-      (defval, deflink) = case feDeferred of
-        (Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index)
-        (Just (EntryBalance target)) -> (Just target, Nothing)
-        Nothing -> (Nothing, Nothing)
+      (cval, ctype, deflink) = case feDeferred of
+        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
+        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
+        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
+        Nothing -> (Nothing, Just TFixed, Nothing)
 
 resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
+resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
   let aRes = lookupAccountKey eAcnt
   let cRes = lookupCurrencyKey feCurrency
   let sRes = lookupAccountSign eAcnt
@@ -516,26 +517,26 @@ readUpdates hashes = do
 
 splitFrom
   :: [(EntryRId, EntryR)]
-  -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
+  -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
 splitFrom from = do
   -- ASSUME entries are sorted by index
   (primary, rest) <- case from of
     ((i, e) : xs) -> return (makeUnkUE i e, xs)
     _ -> throwError $ InsertException undefined
-  let rest' = fmap splitDeferredValue rest
+  rest' <- mapErrors splitDeferredValue rest
   let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
   let (ro, toBal) = partitionEithers rest'
   return (primary, ro, toBal, idxVec)
 
 splitTo
-  :: Vector (Maybe UEBalance)
+  :: Vector (Maybe UEUnk)
   -> [(EntryRId, EntryR)]
   -> InsertExcept
       ( UEBlank
       , [UE_RO]
-      , [UEBalance]
+      , [UEUnk]
       , [UELink]
-      , [(UEBalance, [UELink])]
+      , [(UEUnk, [UELink])]
       )
 splitTo froms tos = do
   -- How to split the credit side of the database transaction in 1024 easy
@@ -552,7 +553,7 @@ splitTo froms tos = do
   let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
 
   -- 2. Split unlinked based on if they have a balance target
-  let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
+  let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
 
   -- 3. Split paired entries by link == 0 (which are special) or link > 0
   let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
@@ -565,10 +566,11 @@ splitTo froms tos = do
   --    then consider the linked entry as another credit read-only entry
   let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
 
-  combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
-    (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
+  combineError3 unlinkedRes paired0Res pairedRes $
+    \(ro, toBal) paired0' (pairedUnk, pairedRO) ->
+      (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
   where
-    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
+    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
     splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
       Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
       Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
@@ -577,18 +579,22 @@ splitTo froms tos = do
       maybe
         (throwError $ InsertException undefined)
         (return . makeUE k e . LinkScale)
-        $ entryRDeferred_value e
+        $ entryRCachedValue e
 
-splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
-splitDeferredValue (k, e) =
-  maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $
-    entryRDeferred_value e
+splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
+splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+  (Nothing, Just TFixed) -> return $ Left $ makeRoUE e
+  (Just v, Just TBalance) -> go EVBalance v
+  (Just v, Just TPercent) -> go EVPercent v
+  _ -> throwError $ InsertException undefined
+  where
+    go c = return . Right . fmap c . makeUE k e
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
 
-makeRoUE :: EntryR -> UpdateEntry () EntryValue
-makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
+makeRoUE :: EntryR -> UpdateEntry () StaticValue
+makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index fcce8ee..9ccba68 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -39,7 +39,7 @@ import qualified RIO.Vector as V
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => HistTransfer
-  -> m [DeferredTx CommitR]
+  -> m [Tx CommitR]
 readHistTransfer
   m@Transfer
     { transFrom = from
@@ -49,11 +49,11 @@ readHistTransfer
     } =
     whenHash0 CTManual m [] $ \c -> do
       bounds <- askDBState kmStatementInterval
-      let precRes = lookupCurrencyPrec u
+      let curRes = lookupCurrency u
       let go Amount {amtWhen, amtValue, amtDesc} = do
             let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, precision) <- combineError dayRes precRes (,)
-            let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc
+            (days, cur) <- combineError dayRes curRes (,)
+            let tx day = txPair c day from to cur amtValue amtDesc
             return $ fmap tx days
       concat <$> mapErrors go amts
 
@@ -61,7 +61,7 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [DeferredTx CommitR])
+  -> m (Either CommitR [Tx CommitR])
 readHistStmt root i = eitherHash CTImport i return $ \c -> do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
@@ -80,9 +80,9 @@ insertHistory
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
   mapM_ updateTx toUpdate
-  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
+  forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
     \(c, ts) -> do
-      ck <- insert $ c
+      ck <- insert c
       mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
@@ -94,23 +94,23 @@ txPair
   -> Day
   -> AcntID
   -> AcntID
-  -> CurID
-  -> Rational
+  -> CurrencyPrec
+  -> Double
   -> T.Text
-  -> DeferredTx CommitR
+  -> Tx CommitR
 txPair commit day from to cur val desc =
   Tx
     { txDescr = desc
     , txDate = day
     , txCommit = commit
-    , txEntries =
-        [ EntrySet
-            { esTotalValue = -val
-            , esCurrency = cur
-            , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
-            , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
-            }
-        ]
+    , txPrimary =
+        EntrySet
+          { esTotalValue = -(roundPrecisionCur cur val)
+          , esCurrency = cur
+          , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
+          , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
+          }
+    , txOther = []
     }
   where
     entry a =
@@ -125,31 +125,27 @@ txPair commit day from to cur val desc =
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m ()
-insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
+insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
   let anyDeferred = any (isJust . feDeferred) ss
   k <- insert $ TransactionR c d e anyDeferred
   mapM_ (insertEntry k) ss
 
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)]
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
 
 --------------------------------------------------------------------------------
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
   records <- L.sort . concat <$> mapErrorsIO readStmt paths
-  m <- askDBState kmCurrency
-  fromEither $
-    flip runReader m $
-      runExceptT $
-        matchRecords compiledMatches records
+  fromEither =<< runExceptT (matchRecords compiledMatches records)
   where
     paths = (root </>) <$> stmtPaths
 
@@ -184,13 +180,11 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
--- TODO need to somehow balance temporally here (like I do in the budget for
--- directives that "pay off" a balance)
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()]
+matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
+    (ms_, [], []) -> return ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
@@ -245,9 +239,10 @@ zipperSlice f x = go
         LT -> z
 
 zipperMatch
-  :: Unzipped MatchRe
+  :: MonadFinance m
+  => Unzipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
+  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -261,9 +256,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
            in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
 zipperMatch'
-  :: Zipped MatchRe
+  :: MonadFinance m
+  => Zipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
+  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -280,7 +276,11 @@ matchDec m = case spTimes m of
   Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchAll
+  :: MonadFinance m
+  => [MatchGroup]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -290,13 +290,21 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchGroup
+  :: MonadFinance m
+  => MatchGroup
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
   return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchDates
+  :: MonadFinance m
+  => [MatchRe]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -317,7 +325,11 @@ matchDates ms = go ([], [], initZipper ms)
           go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchNonDates
+  :: MonadFinance m
+  => [MatchRe]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -337,18 +349,29 @@ matchNonDates ms = go ([], [], initZipper ms)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
-  -> m ([UEBalanced], [KeyTx CommitR])
-balanceTxs es =
+  -> m ([UEBalanced], [InsertTx])
+balanceTxs ebs =
   first concat . partitionEithers . catMaybes
-    <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
+    <$> 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 t@Tx {txEntries}) =
-      (\es' -> Just $ Right $ t {txEntries = concat es'})
-        <$> mapErrors balanceEntrySet txEntries
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
+      let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
+          resN = mapErrors (balanceEntrySet primaryBalance) txOther
+       in combineError res0 resN $ \e es ->
+            -- TODO repacking a Tx into almost the same record seems stupid
+            Just $
+              Right $
+                InsertTx
+                  { itxDescr = txDescr
+                  , itxDate = txDate
+                  , itxEntries = concat $ e : es
+                  , itxCommit = txCommit
+                  }
+    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
 
 binDate :: EntryBin -> Day
 binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
@@ -359,9 +382,10 @@ type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
 data UpdateEntryType a
   = UET_ReadOnly UE_RO
-  | UET_Balance UEBalance
+  | UET_Unk UEUnk
   | UET_Linked a
 
+-- TODO make sure new values are rounded properly here
 rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceEntrySet
   UpdateEntrySet
@@ -377,112 +401,124 @@ rebalanceEntrySet
     , utTotalValue
     } =
     do
-      let fs =
+      (f0val, (tpairs, fs)) <-
+        fmap (second partitionEithers) $
+          foldM goFrom (utTotalValue, []) $
             L.sortOn idx $
               (UET_ReadOnly <$> utFromRO)
-                ++ (UET_Balance <$> utFromUnk)
+                ++ (UET_Unk <$> utFromUnk)
                 ++ (UET_Linked <$> utPairs)
-      fs' <- mapM goFrom fs
-      let f0val = utTotalValue - sum (fmap value fs')
-      let f0 = utFrom0 {ueValue = EntryValue f0val}
-      let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
-      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0
-      let ts =
+      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_Balance <$> utToUnk)
+                ++ (UET_Unk <$> utToUnk)
                 ++ (UET_ReadOnly <$> utToRO)
-      (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
-      let t0val =
-            EntryValue utTotalValue
-              - sum (fmap ueValue tsRO ++ fmap ueValue tsUnk)
-      let t0 = utTo0 {ueValue = t0val}
-      return $ (f0 : fmap (fmap (EntryValue . unBalanceTarget)) fs'') ++ (t0 : tsUnk)
+      let t0 = utTo0 {ueValue = StaticValue t0val}
+      return (f0 : fs ++ (t0 : tsUnk))
     where
       project f _ _ (UET_ReadOnly e) = f e
-      project _ f _ (UET_Balance 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
-      value =
-        project
-          (unEntryValue . ueValue)
-          (unBalanceTarget . ueValue)
-          (unBalanceTarget . ueValue . fst)
-      flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs))
-      -- TODO the following is wetter than the average groupie
-      goFrom (UET_ReadOnly e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
-        return $ UET_ReadOnly e
-      goFrom (UET_Balance e) = do
+      -- 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 newVal = unBalanceTarget (ueValue e) - curBal
-        modify $ mapAdd_ key newVal
-        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
-      goFrom (UET_Linked (e0, es)) = do
-        let key = (ueAcnt e0, utCurrency)
-        curBal <- gets (M.findWithDefault 0 key)
-        let newVal = unBalanceTarget (ueValue e0) - curBal
-        modify $ mapAdd_ key newVal
-        return $
-          UET_Linked
-            ( e0 {ueValue = BalanceTarget newVal}
-            , fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
-            )
-      goTo (UET_ReadOnly e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
-        return $ Left e
-      goTo (UET_Linked e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
-        return $ Right e
-      goTo (UET_Balance e) = do
-        let key = (ueAcnt e, utCurrency)
-        curBal <- gets (M.findWithDefault 0 key)
-        let newVal = unBalanceTarget (ueValue e) - curBal
-        modify $ mapAdd_ key newVal
-        return $ Right $ e {ueValue = EntryValue newVal}
+        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)
-  => DeferredEntrySet
+  => (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
+    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
     , esTotalValue
     } =
     do
-      -- get currency first and quit immediately on exception since everything
-      -- downstream depends on this
-      (curID, precision) <- lookupCurrency esCurrency
+      -- 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
 
-      -- resolve accounts and balance debit entries since we need an array
-      -- of debit entries for linked credit entries later
-      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
-      let fv = V.fromList $ fmap (eValue . feEntry) fs'
+        -- 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))
 
-      -- finally resolve credit entries
-      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
-      ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
-      return $ fs' ++ ts'
+        -- 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, MonadFinance m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId))
+  :: (MonadInsertError m)
+  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () TagID
+  -> Entry AccountRId AcntSign TagRId
   -> [Entry AcntID v TagID]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
+  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
 doEntries f curID tot e es (i0 :| iN) = do
   es' <- mapErrors (uncurry f) $ zip iN es
-  let val0 = tot - entrySum es'
-  e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
+  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)
@@ -502,7 +538,7 @@ 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)
+      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
@@ -513,11 +549,15 @@ balanceLinked from curID precision acntID lg = case lg of
 balanceDeferred
   :: CurrencyRId
   -> AccountRId
-  -> Deferred Rational
+  -> EntryValue Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID (Deferred toBal v) = do
-  newval <- findBalance acntID curID toBal v
-  return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
+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)
@@ -525,7 +565,7 @@ balanceEntry
   -> CurrencyRId
   -> Int
   -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)
+  -> 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
@@ -534,17 +574,37 @@ balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
     (newVal, deferred) <- f acntID eValue
     modify (mapAdd_ (acntID, curID) newVal)
     return $
-      FullEntry
+      InsertEntry
         { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
         , feCurrency = curID
         , feDeferred = deferred
         , feIndex = idx
         }
 
-findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
-findBalance acnt cur toBal v = do
+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 $ if toBal then v - curBal else v
+  return $ case t of
+    TBalance -> v - curBal
+    TPercent -> v * curBal
+    TFixed -> v
 
 -- -- reimplementation from future version :/
 -- mapAccumM
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 8a73112..27fc59f 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -9,6 +9,7 @@ module Internal.Types.Database where
 
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
+import Internal.Types.Dhall
 import RIO
 import qualified RIO.Text as T
 import RIO.Time
@@ -52,8 +53,9 @@ EntryR sql=entries
     memo T.Text
     value Rational
     index Int
-    deferred_value (Maybe Rational)
-    deferred_link (Maybe Int)
+    cachedValue (Maybe Rational)
+    cachedType (Maybe TransferType)
+    cachedLink (Maybe Int)
     deriving Show Eq
 TagRelationR sql=tag_relations
     entry EntryRId OnDeleteCascade
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index c677299..de55bb3 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -34,8 +34,8 @@ makeHaskellTypesWith
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
   , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
-  , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
-  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
+  , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
   , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
@@ -63,7 +63,7 @@ makeHaskellTypesWith
   , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
   , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
   , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
-  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
+  , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
   , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
   , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
@@ -97,7 +97,7 @@ deriveProduct
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
-  , "BudgetCurrency"
+  , "TransferCurrency"
   , "Exchange"
   , "EntryNumGetter"
   , "LinkedNumGetter"
@@ -110,8 +110,8 @@ deriveProduct
   , "TaxProgression"
   , "TaxMethod"
   , "PosttaxValue"
-  , "BudgetTransferValue"
-  , "BudgetTransferType"
+  , "TransferValue"
+  , "TransferType"
   , "Period"
   , "PeriodType"
   , "HourlyPeriod"
@@ -183,7 +183,7 @@ deriving instance Ord DatePat
 deriving instance Hashable DatePat
 
 type BudgetTransfer =
-  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+  Transfer TaggedAcnt TransferCurrency DatePat TransferValue
 
 deriving instance Hashable BudgetTransfer
 
@@ -216,9 +216,21 @@ deriving instance Hashable PosttaxValue
 
 deriving instance Hashable Budget
 
-deriving instance Hashable BudgetTransferValue
+deriving instance Hashable TransferValue
 
-deriving instance Hashable BudgetTransferType
+deriving instance Hashable TransferType
+
+deriving instance Read TransferType
+
+instance PersistFieldSql TransferType where
+  sqlType _ = SqlString
+
+instance PersistField TransferType where
+  toPersistValue = PersistText . T.pack . show
+
+  fromPersistValue (PersistText v) =
+    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
+  fromPersistValue _ = Left "wrong type"
 
 deriving instance Hashable TaggedAcnt
 
@@ -262,7 +274,7 @@ deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
 deriving instance Hashable Exchange
 
-deriving instance Hashable BudgetCurrency
+deriving instance Hashable TransferCurrency
 
 data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 3981583..a5209aa 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -36,7 +36,9 @@ data ConfigHashes = ConfigHashes
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
-type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
+data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
+
+type CurrencyMap = M.Map CurID CurrencyPrec
 
 type TagMap = M.Map TagID TagRId
 
@@ -61,7 +63,10 @@ type CurrencyM = Reader CurrencyMap
 
 -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
 
-data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
+data DBDeferred
+  = EntryLinked Natural Rational
+  | EntryBalance Rational
+  | EntryPercent Rational
 
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
@@ -77,33 +82,37 @@ data UpdateEntry i v = UpdateEntry
   , ueIndex :: !Int -- TODO this isn't needed for primary entries
   }
 
+data CurrencyRound = CurrencyRound CurID Natural
+
 deriving instance Functor (UpdateEntry i)
 
 newtype LinkScale = LinkScale {unLinkScale :: Rational}
   deriving newtype (Num)
 
-newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+-- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+--   deriving newtype (Num)
+
+newtype StaticValue = StaticValue {unStaticValue :: Rational}
   deriving newtype (Num)
 
-newtype EntryValue = EntryValue {unEntryValue :: Rational}
-  deriving newtype (Num)
+data EntryValueUnk = EVBalance Rational | EVPercent Rational
 
-type UEBalance = UpdateEntry EntryRId BalanceTarget
+type UEUnk = UpdateEntry EntryRId EntryValueUnk
 
 type UELink = UpdateEntry EntryRId LinkScale
 
 type UEBlank = UpdateEntry EntryRId ()
 
-type UE_RO = UpdateEntry () EntryValue
+type UE_RO = UpdateEntry () StaticValue
 
-type UEBalanced = UpdateEntry EntryRId EntryValue
+type UEBalanced = UpdateEntry EntryRId StaticValue
 
 data UpdateEntrySet = UpdateEntrySet
   { utFrom0 :: !UEBlank
   , utTo0 :: !UEBlank
-  , utPairs :: ![(UEBalance, [UELink])]
-  , utFromUnk :: ![UEBalance]
-  , utToUnk :: ![UEBalance]
+  , utPairs :: ![(UEUnk, [UELink])]
+  , utFromUnk :: ![UEUnk]
+  , utToUnk :: ![UEUnk]
   , utToUnkLink0 :: ![UELink]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
@@ -115,18 +124,18 @@ data UpdateEntrySet = UpdateEntrySet
 data EntryBin
   = ToUpdate UpdateEntrySet
   | ToRead ReadEntry
-  | ToInsert (DeferredTx CommitR)
+  | ToInsert (Tx CommitR)
 
-data FullEntry a c t = FullEntry
+data InsertEntry a c t = InsertEntry
   { feCurrency :: !c
   , feIndex :: !Int
   , feDeferred :: !(Maybe DBDeferred)
   , feEntry :: !(Entry a Rational t)
   }
 
-type KeyEntry = FullEntry AccountRId CurrencyRId TagRId
+type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
 
-type BalEntry = FullEntry AcntID CurID TagID
+type BalEntry = InsertEntry AcntID CurID TagID
 
 -- type DeferredKeyTx = Tx DeferredKeyEntry
 
@@ -202,50 +211,58 @@ data HalfEntrySet a c t v = HalfEntrySet
   , hesOther :: ![Entry a v t]
   }
 
-data EntrySet a c t v = EntrySet
-  { esTotalValue :: !Rational
+data EntrySet a c t v v' = EntrySet
+  { esTotalValue :: !v'
   , esCurrency :: !c
-  , esFrom :: !(HalfEntrySet a c t (Deferred v))
+  , esFrom :: !(HalfEntrySet a c t (EntryValue v))
   , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
   }
 
-data Tx e c = Tx
+data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txEntries :: !e
-  , txCommit :: !c
+  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational)
+  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)]
+  , txCommit :: !k
   }
   deriving (Generic)
 
-type DeferredEntrySet = EntrySet AcntID CurID TagID Rational
+data InsertTx = InsertTx
+  { itxDescr :: !T.Text
+  , itxDate :: !Day
+  , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
+  , itxCommit :: !CommitR
+  }
+  deriving (Generic)
+
+type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational
 
 type BalEntrySet = EntrySet AcntID CurID TagID Rational
 
 type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
 
-type DeferredTx = Tx [DeferredEntrySet]
+-- type DeferredTx = Tx [DeferredEntrySet]
 
-type BalTx = Tx [BalEntry]
+-- type BalTx = InsertTx [BalEntry]
 
-type KeyTx = Tx [KeyEntry]
+-- type KeyTx = InsertTx [KeyEntry]
 
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
-data LinkDeferred a
-  = LinkDeferred (Deferred a)
-  | LinkIndex LinkedNumGetter
+data EntryValue a = EntryValue TransferType a
   deriving (Show, Functor, Foldable, Traversable)
 
+data LinkDeferred a
+  = LinkDeferred (EntryValue a)
+  | LinkIndex LinkedNumGetter
+  deriving (Show, Functor, Traversable, Foldable)
+
 -- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
--- type BalEntry = Entry AcntID Rational CurID TagID
-
--- type RawTx = Tx RawEntry
-
--- type BalTx = Tx BalEntry
+-- type BalEntry = InsertEntry AcntID CurID TagID
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 656436f..2ec919c 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -65,7 +65,6 @@ where
 
 import Control.Monad.Error.Class
 import Control.Monad.Except
-import Control.Monad.Reader
 import Data.Time.Format.ISO8601
 import GHC.Real
 import Internal.Types.Main
@@ -294,7 +293,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ()))
+matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -311,7 +310,7 @@ matches
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
       convert tg = MatchPass <$> toTx tg r
 
-toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ())
+toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
 toTx
   TxGetter
     { tgFrom
@@ -321,59 +320,43 @@ toTx
     , tgScale
     }
   r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError curRes subRes $ \(cur, f, t, v) ss ->
-      -- TODO might be more efficient to set rebalance flag when balancing
+    combineError curRes subRes $ \(cur, f, t) ss ->
       Tx
         { txDate = trDate
         , txDescr = trDesc
         , txCommit = ()
-        , txEntries =
+        , txPrimary =
             EntrySet
-              { esTotalValue = v
+              { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
               , esCurrency = cur
               , esFrom = f
               , esTo = t
               }
-              : ss
+        , txOther = ss
         }
     where
       curRes = do
-        m <- ask
-        cur <- liftInner $ resolveCurrency r tgCurrency
-        let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
-        let toRes = resolveHalfEntry resolveToValue cur r tgTo
-        let totRes =
-              liftExcept $
-                roundPrecisionCur cur m $
-                  tgScale * fromRational trAmount
-        combineError3 fromRes toRes totRes (cur,,,)
+        m <- askDBState kmCurrency
+        cur <- liftInner $ resolveCurrency m r tgCurrency
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
+        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
+        combineError fromRes toRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
--- anyDeferred :: DeferredEntrySet -> Bool
--- anyDeferred
---   EntrySet
---     { esFrom = HalfEntrySet {hesOther = fs}
---     , esTo = HalfEntrySet {hesOther = ts}
---     } =
---     any checkFrom fs || any checkTo ts
---     where
---       checkFrom Entry {eValue = (Deferred True _)} = True
---       checkFrom _ = False
---       checkTo = undefined
-
 resolveSubGetter
-  :: TxRecord
+  :: MonadFinance m
+  => TxRecord
   -> TxSubGetter
-  -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
+  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- ask
-  cur <- liftInner $ resolveCurrency r tsgCurrency
-  (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
+  m <- askDBState kmCurrency
+  cur <- liftInner $ resolveCurrency m r tsgCurrency
   let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
   let toRes = resolveHalfEntry resolveToValue cur r tsgTo
-  combineError fromRes toRes $ \f t ->
+  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
+  liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
     EntrySet
-      { esTotalValue = val
+      { esTotalValue = v
       , esCurrency = cur
       , esFrom = f
       , esTo = t
@@ -382,10 +365,10 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
 resolveHalfEntry
   :: Traversable f
   => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurID
+  -> CurrencyPrec
   -> TxRecord
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational))
+  -> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
 resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
@@ -399,67 +382,9 @@ resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries}
       , hesOther = es
       }
   where
-    acntRes = liftInner $ resolveAcnt r thgAcnt
+    acntRes = resolveAcnt r thgAcnt
     esRes = mapErrors (resolveEntry f cur r) thgEntries
 
--- resolveSubGetter
---   :: TxRecord
---   -> TxSubGetter
---   -> InsertExceptT CurrencyM DeferredEntrySet
--- resolveSubGetter
---   r
---   TxSubGetter
---     { tsgFromAcnt
---     , tsgToAcnt
---     , tsgFromTags
---     , tsgToTags
---     , tsgFromComment
---     , tsgToComment
---     , tsgValue
---     , tsgCurrency
---     , tsgFromEntries
---     , tsgToEntries
---     } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
---     do
---       m <- ask
---       -- TODO laaaaame...
---       (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
---       let fromEntry =
---             Entry
---               { eAcnt = fa
---               , eValue = ()
---               , eComment = tsgFromComment
---               , eTags = tsgFromTags
---               }
---       let toEntry =
---             Entry
---               { eAcnt = ta
---               , eValue = ()
---               , eComment = tsgToComment
---               , eTags = tsgToTags
---               }
---       return
---         EntrySet
---           { desTotalValue = val
---           , desCurrency = cur
---           , desFromEntry0 = fromEntry
---           , desFromEntries = fe
---           , desToEntries = te
---           , desToEntryBal = toEntry
---           }
---     where
---       resolveAcnt_ = liftInner . resolveAcnt r
---       acntRes =
---         combineError
---           (resolveAcnt_ tsgFromAcnt)
---           (resolveAcnt_ tsgToAcnt)
---           (,)
---       curRes = do
---         cur <- liftInner $ resolveCurrency r tsgCurrency
---         let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
---         let teRes = mapErrors (resolveEntry cur r) tsgToEntries
---         combineError feRes teRes (cur,,)
-
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
   | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
@@ -487,47 +412,17 @@ otherMatches dict m = case m of
 resolveEntry
   :: Traversable f
   => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurID
+  -> CurrencyPrec
   -> TxRecord
   -> EntryGetter n
-  -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID)
+  -> InsertExcept (Entry AcntID (f Rational) TagID)
 resolveEntry f cur r s@Entry {eAcnt, eValue} = do
-  m <- ask
-  liftInner $ combineErrorM acntRes valRes $ \a v -> do
-    v' <- mapM (roundPrecisionCur cur m) v
-    return $ s {eAcnt = a, eValue = v'}
+  combineError acntRes valRes $ \a v ->
+    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
   where
     acntRes = resolveAcnt r eAcnt
     valRes = f r eValue
 
--- resolveEntry
---   :: CurID
---   -> TxRecord
---   -> EntryGetter n
---   -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
--- resolveEntry cur r s@Entry {eAcnt, eValue} = do
---   m <- ask
---   liftInner $ combineErrorM acntRes valRes $ \a v -> do
---     v' <- mapM (roundPrecisionCur cur m) v
---     return $ s {eAcnt = a, eValue = v'}
---   where
---     acntRes = resolveAcnt r eAcnt
---     valRes = resolveValue r eValue
-
--- curRes = resolveCurrency r eCurrency
-
--- -- TODO wet code (kinda, not sure if it's worth combining with above)
--- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
--- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
---   m <- ask
---   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
---     v' <- mapM (roundPrecisionCur c m) v
---     return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
---   where
---     acntRes = resolveAcnt r eAcnt
---     curRes = resolveCurrency r eCurrency
---     valRes = mapM (resolveToValue r) eValue
-
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
 
@@ -621,27 +516,31 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
 collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
-resolveFromValue r = fmap (uncurry Deferred) . resolveValue r
+resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
+resolveFromValue = resolveValue
 
 resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
 resolveToValue _ (Linked l) = return $ LinkIndex l
-resolveToValue r (Getter g) = do
-  (l, v) <- resolveValue r g
-  return $ LinkDeferred (Deferred l v)
+resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double)
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
 resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return (False, c)
-  AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount
-  BalanceN x -> return (True, x)
+  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (ConstN c) -> return $ EntryValue TFixed c
+  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
+  BalanceN x -> return $ EntryValue TBalance x
+  PercentN x -> return $ EntryValue TPercent x
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
 
-resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
-resolveCurrency = resolveEntryField CurField
+resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
+resolveCurrency m r c = do
+  i <- resolveEntryField CurField r c
+  case M.lookup i m of
+    Just k -> return k
+    -- TODO this should be its own error (I think)
+    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
 
 resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveEntryField t TxRecord {trOther = o} s = case s of
@@ -728,11 +627,8 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
   where
     p = 10 ^ n
 
-roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
-roundPrecisionCur c m x =
-  case M.lookup c m of
-    Just (_, n) -> return $ roundPrecision n x
-    Nothing -> throwError $ InsertException [RoundError c]
+roundPrecisionCur :: CurrencyPrec -> Double -> Rational
+roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -1105,14 +1001,14 @@ lookupAccountSign = fmap sndOf3 . lookupAccount
 lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap thdOf3 . lookupAccount
 
-lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural)
+lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
 lookupCurrency = lookupFinance CurField kmCurrency
 
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
-lookupCurrencyKey = fmap fst . lookupCurrency
+lookupCurrencyKey = fmap cpID . lookupCurrency
 
 lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
-lookupCurrencyPrec = fmap snd . lookupCurrency
+lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
 lookupTag = lookupFinance TagField kmTag

From 1ae670187a88a76d9f447f9e9c190c9f6cbbe62e Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 30 Jun 2023 23:54:39 -0400
Subject: [PATCH 32/59] WIP unify history and budget pipelines

---
 dhall/Types.dhall           |  39 +---
 lib/Internal/Budget.hs      | 434 +++++++++++++++++++-----------------
 lib/Internal/History.hs     |  48 ++--
 lib/Internal/Types/Dhall.hs |  14 +-
 lib/Internal/Types/Main.hs  |  12 +-
 lib/Internal/Utils.hs       |   6 +-
 6 files changed, 270 insertions(+), 283 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index d181022..d9dc5d7 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -681,39 +681,6 @@ let Amount =
       \(v : Type) ->
         { amtWhen : w, amtValue : v, amtDesc : Text }
 
-let Exchange =
-    {-
-    A currency exchange.
-    -}
-      { xFromCur :
-          {-
-          Starting currency of the exchange.
-          -}
-          CurID
-      , xToCur :
-          {-
-          Ending currency of the exchange.
-          -}
-          CurID
-      , xAcnt :
-          {-
-          account in which the exchange will be documented.
-          -}
-          AcntID
-      , xRate :
-          {-
-          The exchange rate between the currencies.
-          -}
-          Double
-      }
-
-let TransferCurrency =
-    {-
-    Means to represent currency in a transcaction; either single fixed currency
-    or two currencies with an exchange rate.
-    -}
-      < NoX : CurID | X : Exchange >
-
 let TransferType =
     {-
     The type of a budget transfer.
@@ -1077,7 +1044,7 @@ let ShadowTransfer =
           {-
           Currency of this transfer.
           -}
-          TransferCurrency
+          CurID
       , stDesc :
           {-
           Description of this transfer.
@@ -1103,7 +1070,7 @@ let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type
+      Transfer TaggedAcnt CurID DatePat TransferValue.Type
 
 let Budget =
     {-
@@ -1173,8 +1140,6 @@ in  { CurID
     , TransferMatcher
     , ShadowTransfer
     , AcntSet
-    , TransferCurrency
-    , Exchange
     , TaggedAcnt
     , AccountTree
     , Account
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 672655d..f95dea6 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -4,6 +4,7 @@ import Control.Monad.Except
 import Data.Foldable
 import Database.Persist.Monad
 import Internal.Database
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -44,9 +45,9 @@ insertBudget
       let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
-      m <- askDBState kmCurrency
-      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
-      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
+      shadow <- addShadowTransfers bgtShadowTransfers txs
+      (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
+      void $ insertBudgetTx toIns
     where
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
@@ -61,69 +62,94 @@ insertBudget
 
 -- TODO need to systematically make this function match the history version,
 -- which will allow me to use the same balancing algorithm for both
-balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
-balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
-  where
-    go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
-      let balTo = M.findWithDefault 0 ftTo bals
-          x = amtToMove balTo cvType cvValue
-          bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
-       in (bals', f {ftValue = x})
-    -- TODO might need to query signs to make this intuitive; as it is this will
-    -- probably work, but for credit accounts I might need to supply a negative
-    -- target value
-    amtToMove _ BTFixed x = x
-    amtToMove bal BTPercent x = -(x / 100 * bal)
-    amtToMove bal BTTarget x = x - bal
+-- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry]
+-- balanceTransfers = undefined
+
+-- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
+--   where
+--     go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
+--       let balTo = M.findWithDefault 0 ftTo bals
+--           x = amtToMove balTo cvType cvValue
+--           bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
+--        in (bals', f {ftValue = x})
+--     -- TODO might need to query signs to make this intuitive; as it is this will
+--     -- probably work, but for credit accounts I might need to supply a negative
+--     -- target value
+--     amtToMove _ TFixed x = x
+--     amtToMove bal TPercent x = -(x / 100 * bal)
+--     amtToMove bal TBalance x = x - bal
 
 insertBudgetTx
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => BalancedTransfer
+  => [InsertTx BudgetMeta]
   -> m ()
-insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
-  ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
-  insertPair sFrom sTo
-  forM_ exchange $ uncurry insertPair
+insertBudgetTx toInsert = do
+  forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
+    \(c, ts) -> do
+      ck <- insert $ bmCommit c
+      mapM_ (insertTx ck) ts
   where
-    insertPair from to = do
-      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
-      insertBudgetLabel k from
-      insertBudgetLabel k to
-    insertBudgetLabel k entry = do
+    insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
+      let anyDeferred = any (isJust . feDeferred) ss
+      k <- insert $ TransactionR c d e anyDeferred
+      mapM_ (insertBudgetLabel bmName k) ss
+    insertBudgetLabel n k entry = do
       sk <- insertEntry k entry
-      insert_ $ BudgetLabelR sk $ bmName ftMeta
+      insert_ $ BudgetLabelR sk n
+
+-- insertBudgetTx
+--   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+--   => BalancedTransfer
+--   -> m ()
+-- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+-- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
+-- insertPair sFrom sTo
+-- forM_ exchange $ uncurry insertPair
+-- where
+--   insertPair from to = do
+--     k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+--     insertBudgetLabel k from
+--     insertBudgetLabel k to
+--   insertBudgetLabel k entry = do
+--     sk <- insertEntry k entry
+--     insert_ $ BudgetLabelR sk $ bmName ftMeta
 
 entryPair
   :: (MonadInsertError m, MonadFinance m)
   => TaggedAcnt
   -> TaggedAcnt
-  -> BudgetCurrency
-  -> Rational
-  -> m (EntryPair, Maybe EntryPair)
-entryPair from to cur val = case cur of
-  NoX curid -> (,Nothing) <$> pair curid from to val
-  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
-    let middle = TaggedAcnt xAcnt []
-    let res1 = pair xFromCur from middle val
-    let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
-    combineError res1 res2 $ \a b -> (a, Just b)
+  -> 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
-    pair curid from_ to_ v = do
-      let s1 = entry curid from_ (-v)
-      let s2 = entry curid to_ v
-      combineError s1 s2 (,)
-    entry c TaggedAcnt {taAcnt, taTags} v =
-      resolveEntry $
-        FullEntry
-          { feCurrency = c
-          , feEntry =
-              Entry
-                { eAcnt = taAcnt
-                , eValue = v
-                , eComment = ""
-                , eTags = taTags
-                }
-          }
+    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
+        }
 
 sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
@@ -151,7 +177,7 @@ insertIncome
   -> IntAllocations
   -> Maybe Interval
   -> Income
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 insertIncome
   key
   name
@@ -197,27 +223,34 @@ insertIncome
         let (preDeductions, pre) =
               allocatePre precision gross $
                 flatPre ++ concatMap (selectAllos day) intPre
-            tax =
+        let tax =
               allocateTax precision gross preDeductions scaler $
                 flatTax ++ concatMap (selectAllos day) intTax
             aftertaxGross = gross - sumAllos (tax ++ pre)
-            post =
+        let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-            balance = aftertaxGross - sumAllos post
-            bal =
-              FlatTransfer
-                { ftMeta = meta
-                , ftWhen = day
-                , ftFrom = incFrom
-                , ftCur = NoX incCurrency
-                , ftTo = incToBal
-                , ftValue = UnbalancedValue BTFixed balance
-                , ftDesc = "balance after deductions"
+        let balance = aftertaxGross - sumAllos post
+        -- TODO double or rational here?
+        primary <-
+          entryPair
+            incFrom
+            incToBal
+            incCurrency
+            "balance after deductions"
+            (fromRational balance)
+        allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
+        let bal =
+              Tx
+                { txCommit = meta
+                , txDate = day
+                , txPrimary = primary
+                , txOther = []
+                , txDescr = "balance after deductions"
                 }
-         in if balance < 0
-              then throwError $ InsertException [IncomeError day name balance]
-              else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
+        if balance < 0
+          then throwError $ InsertException [IncomeError day name balance]
+          else return (bal : allos)
 
 periodScaler
   :: PeriodType
@@ -298,7 +331,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = NoX alloCur
+        { faCur = alloCur
         , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
@@ -311,28 +344,30 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = NoX alloCur
+        { faCur = alloCur
         , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
 allo2Trans
-  :: BudgetMeta
+  :: (MonadInsertError m, MonadFinance m)
+  => BudgetMeta
   -> Day
   -> TaggedAcnt
   -> FlatAllocation Rational
-  -> UnbalancedTransfer
-allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
-  FlatTransfer
-    { ftMeta = meta
-    , ftWhen = day
-    , ftFrom = from
-    , ftCur = faCur
-    , ftTo = faTo
-    , ftValue = UnbalancedValue BTFixed faValue
-    , ftDesc = faDesc
-    }
+  -> m (Tx BudgetMeta)
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
+  -- TODO double here?
+  p <- entryPair from faTo faCur faDesc (fromRational faValue)
+  return
+    Tx
+      { txCommit = meta
+      , txDate = day
+      , txPrimary = p
+      , txOther = []
+      , txDescr = faDesc
+      }
 
 allocatePre
   :: Natural
@@ -411,46 +446,43 @@ expandTransfers
   -> T.Text
   -> Maybe Interval
   -> [BudgetTransfer]
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 expandTransfers key name localInterval ts = do
   txs <-
-    fmap (L.sortOn ftWhen . concat) $
+    fmap (L.sortOn txDate . concat) $
       combineErrors $
         fmap (expandTransfer key name) ts
   case localInterval of
     Nothing -> return txs
     Just i -> do
       bounds <- liftExcept $ resolveDaySpan i
-      return $ filter (inDaySpan bounds . ftWhen) txs
+      return $ filter (inDaySpan bounds . txDate) txs
 
 expandTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> BudgetTransfer
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  precision <- lookupCurrencyPrec $ initialCurrency transCurrency
-  fmap concat $ combineErrors $ fmap (go precision) transAmounts
+  fmap concat $ mapErrors go transAmounts
   where
     go
-      precision
       Amount
         { amtWhen = pat
-        , amtValue = BudgetTransferValue {btVal = v, btType = y}
+        , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
         } =
         withDates pat $ \day -> do
           let meta = BudgetMeta {bmCommit = key, bmName = name}
+          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
           return
-            FlatTransfer
-              { ftMeta = meta
-              , ftWhen = day
-              , ftCur = transCurrency
-              , ftFrom = transFrom
-              , ftTo = transTo
-              , ftValue = UnbalancedValue y $ roundPrecision precision v
-              , ftDesc = desc
+            Tx
+              { txCommit = meta
+              , txDate = day
+              , txPrimary = p
+              , txOther = []
+              , txDescr = desc
               }
 
 withDates
@@ -468,63 +500,53 @@ withDates dp f = do
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
-  :: CurrencyMap
-  -> [ShadowTransfer]
-  -> [UnbalancedTransfer]
-  -> InsertExcept [UnbalancedTransfer]
-addShadowTransfers cm ms txs =
-  fmap catMaybes $
-    combineErrors $
-      fmap (uncurry (fromShadow cm)) $
-        [(t, m) | t <- txs, m <- ms]
+  :: (MonadInsertError m, MonadFinance m)
+  => [ShadowTransfer]
+  -> [Tx BudgetMeta]
+  -> m [Tx BudgetMeta]
+addShadowTransfers ms txs = mapErrors go txs
+  where
+    go tx = do
+      es <- catMaybes <$> mapErrors (fromShadow tx) ms
+      return $ tx {txOther = es}
 
 fromShadow
-  :: CurrencyMap
-  -> UnbalancedTransfer
+  :: (MonadInsertError m, MonadFinance m)
+  => Tx BudgetMeta
   -> ShadowTransfer
-  -> InsertExcept (Maybe UnbalancedTransfer)
-fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
-  res <- shadowMatches (stMatch t) tx
-  v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
-  return $
-    if not res
-      then Nothing
-      else
-        Just $
-          FlatTransfer
-            { ftMeta = ftMeta tx
-            , ftWhen = ftWhen tx
-            , ftCur = stCurrency
-            , ftFrom = stFrom
-            , ftTo = stTo
-            , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
-            , ftDesc = stDesc
-            }
+  -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
+fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
+  res <- liftExcept $ shadowMatches stMatch tx
+  es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
+  return $ if not res then Nothing else Just es
 
-shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
-  valRes <- valMatches tmVal $ cvValue $ ftValue tx
+shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} 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
+  -- valRes <- valMatches tmVal $ esTotalValue $ txPrimary
   return $
-    memberMaybe (taAcnt $ ftFrom tx) tmFrom
-      && memberMaybe (taAcnt $ ftTo tx) tmTo
-      && maybe True (`dateMatches` ftWhen tx) tmDate
-      && valRes
+    memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
+      && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
+      && maybe True (`dateMatches` txDate) tmDate
   where
+    -- && valRes
+
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
 --------------------------------------------------------------------------------
 -- random
 
-initialCurrency :: BudgetCurrency -> CurID
-initialCurrency (NoX c) = c
-initialCurrency (X Exchange {xFromCur = c}) = c
+-- initialCurrency :: TransferCurrency -> CurID
+-- initialCurrency (NoX c) = c
+-- initialCurrency (X Exchange {xFromCur = c}) = c
 
 alloAcnt :: Allocation w v -> AcntID
 alloAcnt = taAcnt . alloTo
 
 data UnbalancedValue = UnbalancedValue
-  { cvType :: !BudgetTransferType
+  { cvType :: !TransferType
   , cvValue :: !Rational
   }
   deriving (Show)
@@ -533,75 +555,77 @@ data UnbalancedValue = UnbalancedValue
 -- in the history algorithm, which will entail resolving the budget currency
 -- stuff earlier in the chain, and preloading multiple entries into this thing
 -- before balancing.
-type UnbalancedTransfer = FlatTransfer UnbalancedValue
+-- type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
-ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta
-ubt2tx
-  FlatTransfer
-    { ftFrom
-    , ftTo
-    , ftValue
-    , ftWhen
-    , ftDesc
-    , ftMeta
-    , ftCur
-    } =
-    Tx
-      { txDescr = ftDesc
-      , txDate = ftWhen
-      , txEntries = entries ftCur
-      , txCommit = ftMeta
-      }
-    where
-      entries (NoX curid) = [pair curid ftFrom ftTo ftValue]
-      entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
-        let middle = TaggedAcnt xAcnt []
-            p1 = pair xFromCur ftFrom middle ftValue
-            p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
-         in [p1, p2]
-      pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
-        EntrySet
-          { esTotalValue = v
-          , esCurrency = c
-          , esFrom =
-              HalfEntrySet
-                { hesPrimary =
-                    Entry
-                      { eValue = ()
-                      , eComment = ""
-                      , eAcnt = fa
-                      , eTags = fts
-                      }
-                , hesOther = []
-                }
-          , esTo =
-              HalfEntrySet
-                { hesPrimary =
-                    Entry
-                      { eValue = ()
-                      , eComment = ""
-                      , eAcnt = ta
-                      , eTags = tts
-                      }
-                , hesOther = []
-                }
-          }
+-- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta
+-- ubt2tx
+--   FlatTransfer
+--     { ftFrom
+--     , ftTo
+--     , ftValue
+--     , ftWhen
+--     , ftDesc
+--     , ftMeta
+--     , ftCur
+--     } =
+--     Tx
+--       { txDescr = ftDesc
+--       , txDate = ftWhen
+--       , txPrimary = p
+--       , txOther = maybeToList os
+--       , txCommit = ftMeta
+--       }
+--     where
+--       (p, os) = entries ftCur
+--       entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
+--       entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
+--         let middle = TaggedAcnt xAcnt []
+--             p1 = pair xFromCur ftFrom middle ftValue
+--             p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
+--          in (p1, Just p2)
+--       pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
+--         EntrySet
+--           { esTotalValue = v
+--           , esCurrency = c
+--           , esFrom =
+--               HalfEntrySet
+--                 { hesPrimary =
+--                     Entry
+--                       { eValue = ()
+--                       , eComment = ""
+--                       , eAcnt = fa
+--                       , eTags = fts
+--                       }
+--                 , hesOther = []
+--                 }
+--           , esTo =
+--               HalfEntrySet
+--                 { hesPrimary =
+--                     Entry
+--                       { eValue = ()
+--                       , eComment = ""
+--                       , eAcnt = ta
+--                       , eTags = tts
+--                       }
+--                 , hesOther = []
+--                 }
+--           }
 
-type BalancedTransfer = FlatTransfer Rational
+-- type BalancedTransfer = FlatTransfer Rational
 
-data FlatTransfer v = FlatTransfer
-  { ftFrom :: !TaggedAcnt
-  , ftTo :: !TaggedAcnt
-  , ftValue :: !v
-  , ftWhen :: !Day
-  , ftDesc :: !T.Text
-  , ftMeta :: !BudgetMeta
-  , ftCur :: !BudgetCurrency
-  }
-  deriving (Show)
+-- data FlatTransfer v = FlatTransfer
+--   { ftFrom :: !TaggedAcnt
+--   , ftTo :: !TaggedAcnt
+--   , ftValue :: !v
+--   , ftWhen :: !Day
+--   , ftDesc :: !T.Text
+--   , ftMeta :: !BudgetMeta
+--   , ftCur :: !TransferCurrency
+--   }
+--   deriving (Show)
 
 data BudgetMeta = BudgetMeta
-  { bmCommit :: !CommitRId
+  { bmCommit :: !CommitR
   , bmName :: !T.Text
   }
   deriving (Show)
@@ -622,6 +646,6 @@ data FlatAllocation v = FlatAllocation
   { faValue :: !v
   , faDesc :: !T.Text
   , faTo :: !TaggedAcnt
-  , faCur :: !BudgetCurrency
+  , faCur :: !CurID
   }
   deriving (Functor, Show)
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 9ccba68..f5d67d6 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -3,6 +3,7 @@ module Internal.History
   , readHistTransfer
   , insertHistory
   , splitHistory
+  , balanceTxs
   )
 where
 
@@ -75,7 +76,7 @@ splitHistory = partitionEithers . fmap go
 
 insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin]
+  => [EntryBin CommitR]
   -> m ()
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
@@ -95,17 +96,17 @@ txPair
   -> AcntID
   -> AcntID
   -> CurrencyPrec
-  -> Double
+  -> TransferValue
   -> T.Text
   -> Tx CommitR
-txPair commit day from to cur val desc =
+txPair commit day from to cur (TransferValue t v) desc =
   Tx
     { txDescr = desc
     , txDate = day
     , txCommit = commit
     , txPrimary =
         EntrySet
-          { esTotalValue = -(roundPrecisionCur cur val)
+          { esTotalValue = EntryValue t $ toRational v
           , esCurrency = cur
           , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
           , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
@@ -125,7 +126,7 @@ txPair commit day from to cur val desc =
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m ()
 insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
   let anyDeferred = any (isJust . feDeferred) ss
   k <- insert $ TransactionR c d e anyDeferred
@@ -348,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin]
-  -> m ([UEBalanced], [InsertTx])
+  => [EntryBin a]
+  -> m ([UEBalanced], [InsertTx a])
 balanceTxs ebs =
   first concat . partitionEithers . catMaybes
     <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
@@ -358,22 +359,27 @@ balanceTxs ebs =
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
-      let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
-          resN = mapErrors (balanceEntrySet primaryBalance) txOther
-       in combineError res0 resN $ \e es ->
-            -- TODO repacking a Tx into almost the same record seems stupid
-            Just $
-              Right $
-                InsertTx
-                  { itxDescr = txDescr
-                  , itxDate = txDate
-                  , itxEntries = concat $ e : es
-                  , itxCommit = txCommit
-                  }
+    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 :: EntryBin a -> Day
 binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index de55bb3..9fc74cd 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -34,7 +34,6 @@ makeHaskellTypesWith
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
   , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
-  , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
   , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
@@ -55,8 +54,7 @@ makeHaskellTypesWith
   , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
-    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
-  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
+    SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
   , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
   , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
   , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
@@ -97,8 +95,6 @@ deriveProduct
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
-  , "TransferCurrency"
-  , "Exchange"
   , "EntryNumGetter"
   , "LinkedNumGetter"
   , "LinkedEntryNumGetter"
@@ -183,7 +179,7 @@ deriving instance Ord DatePat
 deriving instance Hashable DatePat
 
 type BudgetTransfer =
-  Transfer TaggedAcnt TransferCurrency DatePat TransferValue
+  Transfer TaggedAcnt CurID DatePat TransferValue
 
 deriving instance Hashable BudgetTransfer
 
@@ -272,10 +268,6 @@ deriving instance (Show w, Show v) => Show (Amount w v)
 
 deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
-deriving instance Hashable Exchange
-
-deriving instance Hashable TransferCurrency
-
 data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
   , alloAmts :: [Amount w v]
@@ -428,7 +420,7 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-type HistTransfer = Transfer AcntID CurID DatePat Double
+type HistTransfer = Transfer AcntID CurID DatePat TransferValue
 
 deriving instance Generic HistTransfer
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index a5209aa..20b461c 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
   , utTotalValue :: !Rational
   }
 
-data EntryBin
+data EntryBin a
   = ToUpdate UpdateEntrySet
   | ToRead ReadEntry
-  | ToInsert (Tx CommitR)
+  | ToInsert (Tx a)
 
 data InsertEntry a c t = InsertEntry
   { feCurrency :: !c
@@ -221,17 +221,17 @@ data EntrySet a c t v v' = EntrySet
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational)
-  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)]
+  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
   , txCommit :: !k
   }
   deriving (Generic)
 
-data InsertTx = InsertTx
+data InsertTx a = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
   , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
-  , itxCommit :: !CommitR
+  , itxCommit :: !a
   }
   deriving (Generic)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 2ec919c..7efa67f 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -327,7 +327,7 @@ toTx
         , txCommit = ()
         , txPrimary =
             EntrySet
-              { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
+              { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
               , esCurrency = cur
               , esFrom = f
               , esTo = t
@@ -347,7 +347,7 @@ resolveSubGetter
   :: MonadFinance m
   => TxRecord
   -> TxSubGetter
-  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- askDBState kmCurrency
   cur <- liftInner $ resolveCurrency m r tsgCurrency
@@ -356,7 +356,7 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
   liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
     EntrySet
-      { esTotalValue = v
+      { esTotalValue = Right v
       , esCurrency = cur
       , esFrom = f
       , esTo = t

From 5c1d2bce9d64fb1b259fa353ac43aa5efdcc4d2f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 1 Jul 2023 13:12:50 -0400
Subject: [PATCH 33/59] WIP unify budget and history pipelines

---
 app/Main.hs                    |  24 ++--
 lib/Internal/Budget.hs         | 202 +++++----------------------------
 lib/Internal/Database.hs       |   4 +-
 lib/Internal/History.hs        |  72 ++++++------
 lib/Internal/Types/Database.hs |   4 +-
 lib/Internal/Types/Main.hs     |  10 +-
 6 files changed, 91 insertions(+), 225 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 597a8c1..336fdda 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -174,19 +174,25 @@ runSync c = do
       liftIOExceptT $ getDBState config
 
     -- read desired statements from disk
-    bSs <-
-      flip runReaderT state $
-        catMaybes <$> mapErrorsIO (readHistStmt root) hSs
+    (rus, is) <-
+      flip runReaderT state $ do
+        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
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      let runHist = do
-            ts <- catMaybes <$> mapErrors readHistTransfer hTs
-            insertHistory $ bSs ++ ts
-      let runBudget = mapErrors insertBudget $ budget config
+      res <- runExceptT $ do
+        -- TODO taking out the hash is dumb
+        (rs, ues) <- readUpdates $ fmap commitRHash rus
+        let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
+        insertAll ebs
+      -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
+      -- whatever error is encountered above in an IO context, but the first
+      -- thrown error should be caught despite possibly needing to be rerun
+      rerunnableIO $ fromEither res
       updateDBState updates -- TODO this will only work if foreign keys are deferred
-      res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
-      rerunnableIO $ fromEither res -- TODO why is this here?
   where
     root = takeDirectory c
     err (InsertException es) = do
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index f95dea6..7cd60b4 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -1,10 +1,8 @@
-module Internal.Budget (insertBudget) where
+module Internal.Budget (readBudget) where
 
 import Control.Monad.Except
 import Data.Foldable
-import Database.Persist.Monad
 import Internal.Database
-import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -25,11 +23,11 @@ import RIO.Time
 -- 4. assign shadow transactions
 -- 5. insert all transactions
 
-insertBudget
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+readBudget
+  :: (MonadInsertError m, MonadFinance m)
   => Budget
-  -> m ()
-insertBudget
+  -> m (Either CommitR [Tx TxCommit])
+readBudget
   b@Budget
     { bgtLabel
     , bgtIncomes
@@ -40,14 +38,13 @@ insertBudget
     , bgtPosttax
     , bgtInterval
     } =
-    whenHash CTBudget b () $ \key -> do
+    eitherHash CTBudget b return $ \key -> do
       (intAllos, _) <- combineError intAlloRes acntRes (,)
-      let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
+      let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
       shadow <- addShadowTransfers bgtShadowTransfers txs
-      (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
-      void $ insertBudgetTx toIns
+      return $ txs ++ shadow
     where
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
@@ -60,60 +57,6 @@ insertBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
 
--- TODO need to systematically make this function match the history version,
--- which will allow me to use the same balancing algorithm for both
--- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry]
--- balanceTransfers = undefined
-
--- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
---   where
---     go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
---       let balTo = M.findWithDefault 0 ftTo bals
---           x = amtToMove balTo cvType cvValue
---           bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
---        in (bals', f {ftValue = x})
---     -- TODO might need to query signs to make this intuitive; as it is this will
---     -- probably work, but for credit accounts I might need to supply a negative
---     -- target value
---     amtToMove _ TFixed x = x
---     amtToMove bal TPercent x = -(x / 100 * bal)
---     amtToMove bal TBalance x = x - bal
-
-insertBudgetTx
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [InsertTx BudgetMeta]
-  -> m ()
-insertBudgetTx toInsert = do
-  forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
-    \(c, ts) -> do
-      ck <- insert $ bmCommit c
-      mapM_ (insertTx ck) ts
-  where
-    insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
-      let anyDeferred = any (isJust . feDeferred) ss
-      k <- insert $ TransactionR c d e anyDeferred
-      mapM_ (insertBudgetLabel bmName k) ss
-    insertBudgetLabel n k entry = do
-      sk <- insertEntry k entry
-      insert_ $ BudgetLabelR sk n
-
--- insertBudgetTx
---   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
---   => BalancedTransfer
---   -> m ()
--- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
--- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
--- insertPair sFrom sTo
--- forM_ exchange $ uncurry insertPair
--- where
---   insertPair from to = do
---     k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
---     insertBudgetLabel k from
---     insertBudgetLabel k to
---   insertBudgetLabel k entry = do
---     sk <- insertEntry k entry
---     insert_ $ BudgetLabelR sk $ bmName ftMeta
-
 entryPair
   :: (MonadInsertError m, MonadFinance m)
   => TaggedAcnt
@@ -170,15 +113,15 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- TODO this will scan the interval allocations fully each time
 -- iteration which is a total waste, but the fix requires turning this
 -- loop into a fold which I don't feel like doing now :(
-insertIncome
+readIncome
   :: (MonadInsertError m, MonadFinance m)
-  => CommitRId
+  => CommitR
   -> T.Text
   -> IntAllocations
   -> Maybe Interval
   -> Income
-  -> m [Tx BudgetMeta]
-insertIncome
+  -> m [Tx TxCommit]
+readIncome
   key
   name
   (intPre, intTax, intPost)
@@ -212,7 +155,7 @@ insertIncome
       dayRes = askDays incWhen localInterval
       start = fromGregorian' $ pStart incPayPeriod
       pType' = pType incPayPeriod
-      meta = BudgetMeta key name
+      meta = BudgetCommit key name
       flatPre = concatMap flattenAllo incPretax
       flatTax = concatMap flattenAllo incTaxes
       flatPost = concatMap flattenAllo incPosttax
@@ -352,11 +295,11 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
 
 allo2Trans
   :: (MonadInsertError m, MonadFinance m)
-  => BudgetMeta
+  => TxCommit
   -> Day
   -> TaggedAcnt
   -> FlatAllocation Rational
-  -> m (Tx BudgetMeta)
+  -> m (Tx TxCommit)
 allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
   -- TODO double here?
   p <- entryPair from faTo faCur faDesc (fromRational faValue)
@@ -441,12 +384,12 @@ allocatePost precision aftertax = fmap (fmap go)
 -- Standalone Transfer
 
 expandTransfers
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => CommitRId
+  :: (MonadInsertError m, MonadFinance m)
+  => CommitR
   -> T.Text
   -> Maybe Interval
   -> [BudgetTransfer]
-  -> m [Tx BudgetMeta]
+  -> m [Tx TxCommit]
 expandTransfers key name localInterval ts = do
   txs <-
     fmap (L.sortOn txDate . concat) $
@@ -459,13 +402,13 @@ expandTransfers key name localInterval ts = do
       return $ filter (inDaySpan bounds . txDate) txs
 
 expandTransfer
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => CommitRId
+  :: (MonadInsertError m, MonadFinance m)
+  => CommitR
   -> T.Text
   -> BudgetTransfer
-  -> m [Tx BudgetMeta]
-expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  fmap concat $ mapErrors go transAmounts
+  -> m [Tx TxCommit]
+expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
+  concat <$> mapErrors go transAmounts
   where
     go
       Amount
@@ -474,7 +417,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
         , amtDesc = desc
         } =
         withDates pat $ \day -> do
-          let meta = BudgetMeta {bmCommit = key, bmName = name}
+          let meta = BudgetCommit key name
           p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
           return
             Tx
@@ -486,7 +429,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
               }
 
 withDates
-  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
+  :: (MonadFinance m, MonadInsertError m)
   => DatePat
   -> (Day -> m a)
   -> m [a]
@@ -502,9 +445,9 @@ withDates dp f = do
 addShadowTransfers
   :: (MonadInsertError m, MonadFinance m)
   => [ShadowTransfer]
-  -> [Tx BudgetMeta]
-  -> m [Tx BudgetMeta]
-addShadowTransfers ms txs = mapErrors go txs
+  -> [Tx TxCommit]
+  -> m [Tx TxCommit]
+addShadowTransfers ms = mapErrors go
   where
     go tx = do
       es <- catMaybes <$> mapErrors (fromShadow tx) ms
@@ -512,7 +455,7 @@ addShadowTransfers ms txs = mapErrors go txs
 
 fromShadow
   :: (MonadInsertError m, MonadFinance m)
-  => Tx BudgetMeta
+  => Tx TxCommit
   -> ShadowTransfer
   -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
@@ -520,7 +463,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
   es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
   return $ if not res then Nothing else Just es
 
-shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
+shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} 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
@@ -538,10 +481,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
 --------------------------------------------------------------------------------
 -- random
 
--- initialCurrency :: TransferCurrency -> CurID
--- initialCurrency (NoX c) = c
--- initialCurrency (X Exchange {xFromCur = c}) = c
-
 alloAcnt :: Allocation w v -> AcntID
 alloAcnt = taAcnt . alloTo
 
@@ -551,85 +490,6 @@ data UnbalancedValue = UnbalancedValue
   }
   deriving (Show)
 
--- TODO need to make this into the same ish thing as the Tx/EntrySet structs
--- in the history algorithm, which will entail resolving the budget currency
--- stuff earlier in the chain, and preloading multiple entries into this thing
--- before balancing.
--- type UnbalancedTransfer = FlatTransfer UnbalancedValue
-
--- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta
--- ubt2tx
---   FlatTransfer
---     { ftFrom
---     , ftTo
---     , ftValue
---     , ftWhen
---     , ftDesc
---     , ftMeta
---     , ftCur
---     } =
---     Tx
---       { txDescr = ftDesc
---       , txDate = ftWhen
---       , txPrimary = p
---       , txOther = maybeToList os
---       , txCommit = ftMeta
---       }
---     where
---       (p, os) = entries ftCur
---       entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
---       entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
---         let middle = TaggedAcnt xAcnt []
---             p1 = pair xFromCur ftFrom middle ftValue
---             p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
---          in (p1, Just p2)
---       pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
---         EntrySet
---           { esTotalValue = v
---           , esCurrency = c
---           , esFrom =
---               HalfEntrySet
---                 { hesPrimary =
---                     Entry
---                       { eValue = ()
---                       , eComment = ""
---                       , eAcnt = fa
---                       , eTags = fts
---                       }
---                 , hesOther = []
---                 }
---           , esTo =
---               HalfEntrySet
---                 { hesPrimary =
---                     Entry
---                       { eValue = ()
---                       , eComment = ""
---                       , eAcnt = ta
---                       , eTags = tts
---                       }
---                 , hesOther = []
---                 }
---           }
-
--- type BalancedTransfer = FlatTransfer Rational
-
--- data FlatTransfer v = FlatTransfer
---   { ftFrom :: !TaggedAcnt
---   , ftTo :: !TaggedAcnt
---   , ftValue :: !v
---   , ftWhen :: !Day
---   , ftDesc :: !T.Text
---   , ftMeta :: !BudgetMeta
---   , ftCur :: !TransferCurrency
---   }
---   deriving (Show)
-
-data BudgetMeta = BudgetMeta
-  { bmCommit :: !CommitR
-  , bmName :: !T.Text
-  }
-  deriving (Show)
-
 type IntAllocations =
   ( [DaySpanAllocation PretaxValue]
   , [DaySpanAllocation TaxValue]
@@ -638,8 +498,6 @@ type IntAllocations =
 
 type DaySpanAllocation = Allocation DaySpan
 
-type EntryPair = (KeyEntry, KeyEntry)
-
 type PeriodScaler = Natural -> Double -> Double
 
 data FlatAllocation v = FlatAllocation
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 2598c59..12fd398 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -459,7 +459,7 @@ resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
   => [Int]
-  -> m [Either ReadEntry UpdateEntrySet]
+  -> m ([ReadEntry], [UpdateEntrySet])
 readUpdates hashes = do
   xs <- selectE $ do
     (commits :& txs :& entries) <-
@@ -482,7 +482,7 @@ readUpdates hashes = do
     liftExcept $
       mapErrors makeUES $
         second (fmap snd) <$> groupWith uGroup toUpdate
-  return $ fmap Left toRead ++ fmap Right toUpdate'
+  return (toRead, toUpdate')
   where
     unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
     uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index f5d67d6..b7da1f3 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -1,9 +1,10 @@
 module Internal.History
   ( readHistStmt
   , readHistTransfer
-  , insertHistory
+  , insertAll
   , splitHistory
   , balanceTxs
+  , updateTx
   )
 where
 
@@ -26,21 +27,11 @@ import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 
--- readHistory
---   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
---   => FilePath
---   -> [History]
---   -> m [(CommitR, [DeferredTx])]
--- readHistory root hs = do
---   let (ts, ss) = splitHistory hs
---   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
---   ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
---   return $ ts' ++ ss'
-
+-- TODO unify this with the transfer system I use in the budget now
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => HistTransfer
-  -> m [Tx CommitR]
+  -> m (Either CommitR [Tx TxCommit])
 readHistTransfer
   m@Transfer
     { transFrom = from
@@ -48,7 +39,7 @@ readHistTransfer
     , transCurrency = u
     , transAmounts = amts
     } =
-    whenHash0 CTManual m [] $ \c -> do
+    eitherHash CTManual m return $ \c -> do
       bounds <- askDBState kmStatementInterval
       let curRes = lookupCurrency u
       let go Amount {amtWhen, amtValue, amtDesc} = do
@@ -62,11 +53,11 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [Tx CommitR])
+  -> m (Either CommitR [Tx TxCommit])
 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 = c}) bs
+  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
 
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
@@ -74,17 +65,35 @@ splitHistory = partitionEithers . fmap go
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-insertHistory
+insertAll
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin CommitR]
+  => [EntryBin]
   -> m ()
-insertHistory hs = do
-  (toUpdate, toInsert) <- balanceTxs hs
+insertAll ebs = do
+  (toUpdate, toInsert) <- balanceTxs ebs
   mapM_ updateTx toUpdate
-  forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
+  forM_ (groupWith itxCommit toInsert) $
     \(c, ts) -> do
-      ck <- insert c
+      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
@@ -98,12 +107,12 @@ txPair
   -> CurrencyPrec
   -> TransferValue
   -> T.Text
-  -> Tx CommitR
+  -> Tx TxCommit
 txPair commit day from to cur (TransferValue t v) desc =
   Tx
     { txDescr = desc
     , txDate = day
-    , txCommit = commit
+    , txCommit = HistoryCommit commit
     , txPrimary =
         EntrySet
           { esTotalValue = EntryValue t $ toRational v
@@ -126,15 +135,6 @@ txPair commit day from to cur (TransferValue t v) desc =
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m ()
-insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
-  let anyDeferred = any (isJust . feDeferred) ss
-  k <- insert $ TransactionR c d e anyDeferred
-  mapM_ (insertEntry k) ss
-
-updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
-
 --------------------------------------------------------------------------------
 -- Statements
 
@@ -349,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin a]
-  -> m ([UEBalanced], [InsertTx a])
+  => [EntryBin]
+  -> m ([UEBalanced], [InsertTx])
 balanceTxs ebs =
   first concat . partitionEithers . catMaybes
     <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
@@ -379,7 +379,7 @@ balanceTxs ebs =
       Right (EntryValue t v) -> findBalance eAcnt c t v
       Left v -> return $ toRational v * tot
 
-binDate :: EntryBin a -> Day
+binDate :: EntryBin -> Day
 binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 27fc59f..9df0bc4 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -20,7 +20,7 @@ share
 CommitR sql=commits
     hash Int
     type ConfigType
-    deriving Show Eq
+    deriving Show Eq Ord
 CurrencyR sql=currencies
     symbol T.Text
     fullname T.Text
@@ -67,7 +67,7 @@ BudgetLabelR sql=budget_labels
 |]
 
 data ConfigType = CTBudget | CTManual | CTImport
-  deriving (Eq, Show, Read, Enum)
+  deriving (Eq, Show, Read, Enum, Ord)
 
 instance PersistFieldSql ConfigType where
   sqlType _ = SqlString
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 20b461c..c02606d 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
   , utTotalValue :: !Rational
   }
 
-data EntryBin a
+data EntryBin
   = ToUpdate UpdateEntrySet
   | ToRead ReadEntry
-  | ToInsert (Tx a)
+  | ToInsert (Tx TxCommit)
 
 data InsertEntry a c t = InsertEntry
   { feCurrency :: !c
@@ -218,6 +218,8 @@ data EntrySet a c t v v' = EntrySet
   , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
   }
 
+data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
+
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
@@ -227,11 +229,11 @@ data Tx k = Tx
   }
   deriving (Generic)
 
-data InsertTx a = InsertTx
+data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
   , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
-  , itxCommit :: !a
+  , itxCommit :: !TxCommit
   }
   deriving (Generic)
 

From ebef4e0f6b949441b004078500d9b6b49b0215b1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 1 Jul 2023 18:32:20 -0400
Subject: [PATCH 34/59] WIP mostly unify history and budget transfer pipelines

---
 dhall/Types.dhall           |  28 +++---
 lib/Internal/Budget.hs      | 137 ++++++----------------------
 lib/Internal/History.hs     | 173 ++++++++++++++++++++++++++----------
 lib/Internal/Types/Dhall.hs |  23 ++---
 lib/Internal/Utils.hs       |   1 +
 5 files changed, 176 insertions(+), 186 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index d9dc5d7..a48121e 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -714,11 +714,19 @@ let Transfer =
         , transAmounts : List (Amount w v)
         }
 
+let TaggedAcnt =
+    {-
+    An account with a tag
+    -}
+      { Type = { taAcnt : AcntID, taTags : List TagID }
+      , default.taTags = [] : List TagID
+      }
+
 let HistTransfer =
     {-
     A manually specified historical transfer
     -}
-      Transfer AcntID CurID DatePat TransferValue.Type
+      Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
 
 let Statement =
     {-
@@ -755,12 +763,6 @@ let History =
     -}
       < HistTransfer : HistTransfer | HistStatement : Statement >
 
-let TaggedAcnt =
-    {-
-    An account with a tag
-    -}
-      { taAcnt : AcntID, taTags : List TagID }
-
 let Allocation =
     {-
     How to allocate a given budget stream. This can be thought of as a Transfer
@@ -768,7 +770,7 @@ let Allocation =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { alloTo : TaggedAcnt
+        { alloTo : TaggedAcnt.Type
         , alloAmts : List (Amount w v)
         , alloCur :
             {-TODO allow exchanges here-}
@@ -958,13 +960,13 @@ let Income =
               This must be an income AcntID, and is the only place income
               accounts may be specified in the entire budget.
               -}
-              TaggedAcnt
+              TaggedAcnt.Type
           , incToBal :
               {-
               The account to which to send the remainder of the income stream
               (if any) after all allocations have been applied.
               -}
-              TaggedAcnt
+              TaggedAcnt.Type
           }
       , default =
         { incPretax = [] : List (SingleAllocation PretaxValue)
@@ -1034,12 +1036,12 @@ let ShadowTransfer =
           {-
           Source of this transfer
           -}
-          TaggedAcnt
+          TaggedAcnt.Type
       , stTo :
           {-
           Destination of this transfer.
           -}
-          TaggedAcnt
+          TaggedAcnt.Type
       , stCurrency :
           {-
           Currency of this transfer.
@@ -1070,7 +1072,7 @@ let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt CurID DatePat TransferValue.Type
+      HistTransfer
 
 let Budget =
     {-
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 7cd60b4..22d5179 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -3,6 +3,7 @@ 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)
@@ -39,12 +40,17 @@ readBudget
     , bgtInterval
     } =
     eitherHash CTBudget b return $ \key -> do
-      (intAllos, _) <- combineError intAlloRes acntRes (,)
-      let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
-      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
-      txs <- combineError (concat <$> res1) res2 (++)
-      shadow <- addShadowTransfers bgtShadowTransfers txs
-      return $ txs ++ shadow
+      spanRes <- getSpan
+      case spanRes of
+        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 (Just budgetSpan) bgtTransfers
+          txs <- combineError (concat <$> res1) res2 (++)
+          shadow <- addShadowTransfers bgtShadowTransfers txs
+          return $ txs ++ shadow
     where
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
@@ -56,43 +62,13 @@ readBudget
         (alloAcnt <$> bgtPretax)
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
-
-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
-        }
+      getSpan = do
+        globalSpan <- askDBState kmBudgetInterval
+        case bgtInterval of
+          Nothing -> return $ Just globalSpan
+          Just bi -> do
+            localSpan <- liftExcept $ resolveDaySpan bi
+            return $ intersectDaySpan globalSpan localSpan
 
 sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
@@ -115,17 +91,15 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- loop into a fold which I don't feel like doing now :(
 readIncome
   :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
+  => TxCommit
   -> IntAllocations
-  -> Maybe Interval
+  -> DaySpan
   -> Income
   -> m [Tx TxCommit]
 readIncome
-  key
-  name
+  tc
   (intPre, intTax, intPost)
-  localInterval
+  ds
   Income
     { incWhen
     , incCurrency
@@ -152,10 +126,9 @@ readIncome
             ++ (alloAcnt <$> incTaxes)
             ++ (alloAcnt <$> incPosttax)
       precRes = lookupCurrencyPrec incCurrency
-      dayRes = askDays incWhen localInterval
+      dayRes = liftExcept $ expandDatePat ds incWhen
       start = fromGregorian' $ pStart incPayPeriod
       pType' = pType incPayPeriod
-      meta = BudgetCommit key name
       flatPre = concatMap flattenAllo incPretax
       flatTax = concatMap flattenAllo incTaxes
       flatPost = concatMap flattenAllo incPosttax
@@ -182,17 +155,18 @@ readIncome
             incCurrency
             "balance after deductions"
             (fromRational balance)
-        allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
+        allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
         let bal =
               Tx
-                { txCommit = meta
+                { txCommit = tc
                 , txDate = day
                 , txPrimary = primary
                 , txOther = []
                 , txDescr = "balance after deductions"
                 }
+        -- TODO use real name here
         if balance < 0
-          then throwError $ InsertException [IncomeError day name balance]
+          then throwError $ InsertException [IncomeError day "" balance]
           else return (bal : allos)
 
 periodScaler
@@ -383,61 +357,6 @@ allocatePost precision aftertax = fmap (fmap go)
 --------------------------------------------------------------------------------
 -- Standalone Transfer
 
-expandTransfers
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
-  -> Maybe Interval
-  -> [BudgetTransfer]
-  -> m [Tx TxCommit]
-expandTransfers key name localInterval ts = do
-  txs <-
-    fmap (L.sortOn txDate . concat) $
-      combineErrors $
-        fmap (expandTransfer key name) ts
-  case localInterval of
-    Nothing -> return txs
-    Just i -> do
-      bounds <- liftExcept $ resolveDaySpan i
-      return $ filter (inDaySpan bounds . txDate) txs
-
-expandTransfer
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
-  -> BudgetTransfer
-  -> m [Tx TxCommit]
-expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
-  concat <$> mapErrors go transAmounts
-  where
-    go
-      Amount
-        { amtWhen = pat
-        , amtValue = TransferValue {tvVal = v, tvType = t}
-        , amtDesc = desc
-        } =
-        withDates pat $ \day -> do
-          let meta = BudgetCommit key name
-          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
-          return
-            Tx
-              { txCommit = meta
-              , txDate = day
-              , txPrimary = p
-              , txOther = []
-              , txDescr = desc
-              }
-
-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
-
 --------------------------------------------------------------------------------
 -- shadow transfers
 
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index b7da1f3..a586ec5 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -5,6 +5,9 @@ module Internal.History
   , splitHistory
   , balanceTxs
   , updateTx
+  , entryPair_
+  , expandTransfers
+  , entryPair
   )
 where
 
@@ -30,24 +33,11 @@ import qualified RIO.Vector as V
 -- TODO unify this with the transfer system I use in the budget now
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
-  => HistTransfer
+  => PairedTransfer
   -> m (Either CommitR [Tx TxCommit])
-readHistTransfer
-  m@Transfer
-    { transFrom = from
-    , transTo = to
-    , transCurrency = u
-    , transAmounts = amts
-    } =
-    eitherHash CTManual m return $ \c -> do
-      bounds <- askDBState kmStatementInterval
-      let curRes = lookupCurrency u
-      let go Amount {amtWhen, amtValue, amtDesc} = do
-            let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, cur) <- combineError dayRes curRes (,)
-            let tx day = txPair c day from to cur amtValue amtDesc
-            return $ fmap tx days
-      concat <$> mapErrors go amts
+readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
+  bounds <- askDBState kmStatementInterval
+  expandTransfer (HistoryCommit c) (Just bounds) ht
 
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
@@ -59,7 +49,7 @@ 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] -> ([HistTransfer], [Statement])
+splitHistory :: [History] -> ([PairedTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
   where
     go (HistTransfer x) = Left x
@@ -98,38 +88,125 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
--- 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 = []
-    }
+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
-    entry a =
-      Entry
-        { eAcnt = a
-        , eValue = ()
-        , eComment = ""
-        , eTags = []
+    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} =
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 9fc74cd..31eadd0 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -40,7 +40,7 @@ makeHaskellTypesWith
   , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@@ -178,14 +178,13 @@ deriving instance Ord DatePat
 
 deriving instance Hashable DatePat
 
-type BudgetTransfer =
-  Transfer TaggedAcnt CurID DatePat TransferValue
+type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
 
-deriving instance Hashable BudgetTransfer
+deriving instance Hashable PairedTransfer
 
-deriving instance Generic BudgetTransfer
+deriving instance Generic PairedTransfer
 
-deriving instance FromDhall BudgetTransfer
+deriving instance FromDhall PairedTransfer
 
 data Budget = Budget
   { bgtLabel :: Text
@@ -193,7 +192,7 @@ data Budget = Budget
   , bgtPretax :: [MultiAllocation PretaxValue]
   , bgtTax :: [MultiAllocation TaxValue]
   , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: [BudgetTransfer]
+  , bgtTransfers :: [PairedTransfer]
   , bgtShadowTransfers :: [ShadowTransfer]
   , bgtInterval :: !(Maybe Interval)
   }
@@ -420,16 +419,8 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-type HistTransfer = Transfer AcntID CurID DatePat TransferValue
-
-deriving instance Generic HistTransfer
-
-deriving instance Hashable HistTransfer
-
-deriving instance FromDhall HistTransfer
-
 data History
-  = HistTransfer !HistTransfer
+  = HistTransfer !PairedTransfer
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 7efa67f..bab86fd 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -274,6 +274,7 @@ intersectDaySpan a b =
 
 resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
 resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
+  -- TODO the default isn't checked here :/
   case fromGregorian' <$> e of
     Nothing -> return $ toDaySpan_ $ fromGregorian' def
     Just e_

From d5761c75ed8710367f17186ef5a39868eadb688c Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 1 Jul 2023 18:58:15 -0400
Subject: [PATCH 35/59] REF move commont stuff to common modules

---
 app/Main.hs              |   9 +-
 lib/Internal/Budget.hs   |  23 +-
 lib/Internal/Database.hs |  33 +++
 lib/Internal/History.hs  | 470 ++-------------------------------------
 lib/Internal/Utils.hs    | 354 +++++++++++++++++++++++++++++
 5 files changed, 409 insertions(+), 480 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 336fdda..7a98ed8 100644
--- a/app/Main.hs
+++ b/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
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 22d5179..78a10a4 100644
--- a/lib/Internal/Budget.hs
+++ b/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]
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 12fd398..7617512 100644
--- a/lib/Internal/Database.hs
+++ b/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]
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index a586ec5..3b7176f 100644
--- a/lib/Internal/History.hs
+++ b/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
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index bab86fd..059cd10 100644
--- a/lib/Internal/Utils.hs
+++ b/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

From bae847d9f3aa6258bd0c94abcb170c745a25c1b5 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 3 Jul 2023 20:27:52 -0400
Subject: [PATCH 36/59] WIP balance transactions in two different ways

---
 app/Main.hs                    |   4 +-
 lib/Internal/Budget.hs         |  32 +--
 lib/Internal/Database.hs       | 338 ++++++++++++++++-------------
 lib/Internal/Types/Database.hs |   8 +-
 lib/Internal/Types/Dhall.hs    |   2 +-
 lib/Internal/Types/Main.hs     | 103 +++++----
 lib/Internal/Utils.hs          | 376 ++++++++++++++++++++-------------
 7 files changed, 521 insertions(+), 342 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 7a98ed8..a4847bd 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -180,10 +180,13 @@ runSync c = do
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
+        -- lift $ print hTs'
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
+      -- NOTE this must come first (unless we defer foreign keys)
+      updateDBState updates
       res <- runExceptT $ do
         -- TODO taking out the hash is dumb
         (rs, ues) <- readUpdates $ fmap commitRHash rus
@@ -193,7 +196,6 @@ runSync c = do
       -- whatever error is encountered above in an IO context, but the first
       -- thrown error should be caught despite possibly needing to be rerun
       rerunnableIO $ fromEither res
-      updateDBState updates -- TODO this will only work if foreign keys are deferred
   where
     root = takeDirectory c
     err (InsertException es) = do
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 78a10a4..c635fbb 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -143,12 +143,14 @@ readIncome
             incCurrency
             "balance after deductions"
             (fromRational balance)
+            ()
+        -- TODO make this into one large tx?
         allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
         let bal =
               Tx
                 { txCommit = tc
                 , txDate = day
-                , txPrimary = primary
+                , txPrimary = Left primary
                 , txOther = []
                 , txDescr = "balance after deductions"
                 }
@@ -264,12 +266,12 @@ allo2Trans
   -> m (Tx TxCommit)
 allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
   -- TODO double here?
-  p <- entryPair from faTo faCur faDesc (fromRational faValue)
+  p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
   return
     Tx
       { txCommit = meta
       , txDate = day
-      , txPrimary = p
+      , txPrimary = Left p
       , txOther = []
       , txDescr = faDesc
       }
@@ -355,30 +357,36 @@ addShadowTransfers ms = mapErrors go
   where
     go tx = do
       es <- catMaybes <$> mapErrors (fromShadow tx) ms
-      return $ tx {txOther = es}
+      return $ tx {txOther = Right <$> es}
 
 fromShadow
   :: (MonadInsertError m, MonadFinance m)
   => Tx TxCommit
   -> ShadowTransfer
-  -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
+  -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
   res <- liftExcept $ shadowMatches stMatch tx
-  es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
+  es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
   return $ if not res then Nothing else Just es
 
 shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
+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
-  -- valRes <- valMatches tmVal $ esTotalValue $ txPrimary
+  valRes <- case txPrimary of
+    Left es -> valMatches tmVal $ esTotalValue es
+    Right _ -> return True
   return $
-    memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
-      && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
+    memberMaybe fa tmFrom
+      && memberMaybe ta tmTo
       && maybe True (`dateMatches` txDate) tmDate
+      && valRes
   where
-    -- && valRes
-
+    fa = either getAcntFrom getAcntFrom txPrimary
+    ta = either getAcntTo getAcntTo txPrimary
+    getAcntFrom = getAcnt esFrom
+    getAcntTo = getAcnt esTo
+    getAcnt f = eAcnt . hesPrimary . f
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 7617512..a376588 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -13,7 +13,6 @@ module Internal.Database
   , whenHash_
   , eitherHash
   , insertEntry
-  , resolveEntry
   , readUpdates
   , insertAll
   , updateTx
@@ -46,9 +45,8 @@ import RIO hiding (LogFunc, isNothing, on, (^.))
 import RIO.List ((\\))
 import qualified RIO.List as L
 import qualified RIO.Map as M
-import qualified RIO.NonEmpty as N
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
-import qualified RIO.Vector as V
 
 runDB
   :: MonadUnliftIO m
@@ -246,10 +244,10 @@ paths2IDs =
     . fmap (first pathList)
   where
     pathList (AcntPath t []) = atName t :| []
-    pathList (AcntPath t ns) = N.reverse $ atName t :| ns
+    pathList (AcntPath t ns) = NE.reverse $ atName t :| ns
 
 -- none of these errors should fire assuming that input is sorted and unique
-trimNames :: [N.NonEmpty T.Text] -> [AcntID]
+trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
 trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
   where
     trimAll _ [] = []
@@ -270,10 +268,10 @@ trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
                   [] -> [trim i y]
                   _ -> trimAll (i + 1) (reverse $ y : ys)
              in (new, [], reverse next ++ old)
-    trim i = N.take (i + 1)
+    trim i = NE.take (i + 1)
     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
 
-(!?) :: N.NonEmpty a -> Int -> Maybe a
+(!?) :: NE.NonEmpty a -> Int -> Maybe a
 xs !? n
   | n < 0 = Nothing
   -- Definition adapted from GHC.List
@@ -410,7 +408,7 @@ eitherHash t o f g = do
   let h = hash o
   let c = CommitR h t
   hs <- askDBState kmNewCommits
-  if h `elem` hs then Left <$> f c else Right <$> g c
+  if h `elem` hs then Right <$> g c else Left <$> f c
 
 whenHash_
   :: (Hashable a, MonadFinance m)
@@ -424,174 +422,206 @@ whenHash_ t o f = do
   hs <- askDBState kmNewCommits
   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
-insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
-insertEntry
-  t
-  InsertEntry
-    { feEntry = Entry {eValue, eTags, eAcnt, eComment}
-    , feCurrency
-    , feIndex
-    , feDeferred
-    } =
-    do
-      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
-      mapM_ (insert_ . TagRelationR k) eTags
-      return k
-    where
-      (cval, ctype, deflink) = case feDeferred of
-        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
-        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
-        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
-        Nothing -> (Nothing, Just TFixed, 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}
-        }
+-- 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]
-  -> m ([ReadEntry], [UpdateEntrySet])
+  -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
 readUpdates hashes = do
   xs <- selectE $ do
-    (commits :& txs :& entries) <-
+    (commits :& txs :& entrysets :& entries) <-
       E.from
         $ E.table @CommitR
           `E.innerJoin` E.table @TransactionR
         `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
+          `E.innerJoin` E.table @EntrySetR
+        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table @EntryR
-        `E.on` (\(_ :& t :& e) -> t ^. TransactionRId ==. e ^. EntryRTransaction)
+        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
     return
-      ( txs ^. TransactionRDeferred
-      , txs ^. TransactionRDate
-      , entries
+      ( entrysets ^. EntrySetRRebalance
+      ,
+        (
+          ( entrysets ^. EntrySetRId
+          , txs ^. TransactionRDate
+          , entrysets ^. EntrySetRCurrency
+          )
+        , entries
+        )
       )
-  let (toUpdate, toRead) =
-        bimap unpack (fmap makeRE . unpack) $
-          L.partition (\(d, _, _) -> E.unValue d) xs
-  toUpdate' <-
-    liftExcept $
-      mapErrors makeUES $
-        second (fmap snd) <$> groupWith uGroup toUpdate
-  return (toRead, toUpdate')
+  let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
+  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
+  return (makeRE . snd <$> toRead, toUpdate')
   where
-    unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
-    uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
-    makeUES ((day, cur, _), es) = do
-      let (froms, tos) =
-            L.partition ((< 0) . entryRIndex . snd) $
-              L.sortOn (entryRIndex . snd) es
-      let tot = sum $ fmap (entryRValue . snd) froms
-      (from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
-      (to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
-      return
-        UpdateEntrySet
-          { utDate = day
-          , utCurrency = cur
-          , utFrom0 = from0
-          , utTo0 = to0
-          , utFromRO = fromRO
-          , utToRO = toRO
-          , utToUnkLink0 = toLink0
-          , utPairs = toLinkN
-          , utFromUnk = fromUnk
-          , utToUnk = toUnk
-          , utTotalValue = tot
-          }
-    makeRE (d, (_, e)) =
-      ReadEntry
-        { reDate = d
-        , reCurrency = entryRCurrency e
-        , reAcnt = entryRAccount e
-        , reValue = entryRValue e
-        }
+    makeUES ((_, day, curID), es) = do
+      let res =
+            bimap NE.nonEmpty NE.nonEmpty $
+              NE.partition ((< 0) . entryRIndex . snd) $
+                NE.sortWith (entryRIndex . snd) $
+                  fmap (\e -> (entityKey e, entityVal e)) es
+      case res of
+        (Just froms, Just tos) -> do
+          let tot = sum $ fmap (entryRValue . snd) froms
+          (from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
+          (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
+          -- TODO WAP (wet ass programming)
+          return $ case from0' of
+            Left x ->
+              Left $
+                UpdateEntrySet
+                  { utDate = E.unValue day
+                  , utCurrency = E.unValue curID
+                  , utFrom0 = x
+                  , utTo0 = to0
+                  , utFromRO = fromRO
+                  , utToRO = toRO
+                  , utFromUnk = fromUnk
+                  , utToUnk = toUnk
+                  , utTotalValue = tot
+                  }
+            Right x ->
+              Right $
+                UpdateEntrySet
+                  { utDate = E.unValue day
+                  , utCurrency = E.unValue curID
+                  , utFrom0 = x
+                  , utTo0 = to0
+                  , utFromRO = fromRO
+                  , utToRO = toRO
+                  , utFromUnk = fromUnk
+                  , utToUnk = toUnk
+                  , utTotalValue = ()
+                  }
+        _ -> throwError undefined
+    makeRE ((_, day, curID), entry) =
+      let e = entityVal entry
+       in ReadEntry
+            { reDate = E.unValue day
+            , reCurrency = E.unValue curID
+            , reAcnt = entryRAccount e
+            , reValue = entryRValue e
+            }
 
 splitFrom
-  :: [(EntryRId, EntryR)]
-  -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
-splitFrom from = do
+  :: NonEmpty (EntryRId, EntryR)
+  -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
+splitFrom (f0 :| fs) = do
   -- ASSUME entries are sorted by index
-  (primary, rest) <- case from of
-    ((i, e) : xs) -> return (makeUnkUE i e, xs)
-    _ -> throwError $ InsertException undefined
-  rest' <- mapErrors splitDeferredValue rest
-  let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
-  let (ro, toBal) = partitionEithers rest'
-  return (primary, ro, toBal, idxVec)
+  -- TODO combine errors here
+  let f0Res = readDeferredValue f0
+  let fsRes = mapErrors splitDeferredValue fs
+  combineErrorM f0Res fsRes $ \f0' fs' -> do
+    let (ro, unk) = partitionEithers fs'
+    -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
+    return (f0', ro, unk)
 
 splitTo
-  :: Vector (Maybe UEUnk)
-  -> [(EntryRId, EntryR)]
+  :: Either UEBlank (Either UE_RO UEUnk)
+  -> [UEUnk]
+  -> NonEmpty (EntryRId, EntryR)
   -> InsertExcept
-      ( UEBlank
+      ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
+      , [(UEUnk, [UELink])]
+      , UEBlank
       , [UE_RO]
       , [UEUnk]
-      , [UELink]
-      , [(UEUnk, [UELink])]
       )
-splitTo froms tos = do
+splitTo from0 fromUnk (t0 :| ts) = do
   -- How to split the credit side of the database transaction in 1024 easy
   -- steps:
   --
-  -- 1. ASSUME the entries are sorted by index. Isolate the first as the
-  --    primary and puke in user's face if list is empty (which it should never
-  --    be)
-  (primary, rest) <- case tos of
-    ((i, e) : xs) -> return (makeUnkUE i e, xs)
-    _ -> throwError $ InsertException undefined
+  -- 1. Split incoming entries (except primary) into those with links and not
+  let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
 
-  -- 1. Split the entries based on if they have a link
-  let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
-
-  -- 2. Split unlinked based on if they have a balance target
+  -- 2. For unlinked entries, split into read-only and unknown entries
   let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
 
-  -- 3. Split paired entries by link == 0 (which are special) or link > 0
-  let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
-  let paired0Res = mapErrors (makeLinkUnk . snd) paired0
+  -- 3. For linked entries, split into those that link to the primary debit
+  --    entry and not
+  let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
 
-  -- 4. Group linked entries (which now have links > 0) according to the debit
-  --    entry to which they are linked. If the debit entry cannot be found or
-  --    if the linked entry has no scale, blow up in user's face. If the
-  --    debit entry is read-only (signified by Nothing in the 'from' array)
-  --    then consider the linked entry as another credit read-only entry
-  let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
+  -- 4. For linked entries that don't link to the primary debit entry, split
+  --    into those that link to an unknown debit entry or not. Those that
+  --    are not will be read-only and those that are will be collected with
+  --    their linked debit entry
+  let linkedRes = zipPaired fromUnk linkedN
 
-  combineError3 unlinkedRes paired0Res pairedRes $
-    \(ro, toBal) paired0' (pairedUnk, pairedRO) ->
-      (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
+  -- 5. For entries linked to the primary debit entry, turn them into linked
+  --    entries (lazily only used when needed later)
+  let from0Res = mapErrors (makeLinkUnk . snd) linked0
+
+  combineErrorM3 from0Res linkedRes unlinkedRes $
+    -- 6. Depending on the type of primary debit entry we have, add linked
+    --    entries if it is either an unknown or a blank (to be solved) entry,
+    --    or turn the remaining linked entries to read-only and add to the other
+    --    read-only entries
+    \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
+      let (from0', toROLinked0) = case from0 of
+            Left blnk -> (Left (blnk, from0Links), [])
+            Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0)
+            Right (Right unk) -> (Right $ Right (unk, from0Links), [])
+      return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
   where
+    primary = uncurry makeUnkUE t0
     splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
-    splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
-      Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
-      Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
-      Nothing -> throwError $ InsertException undefined
-    makeLinkUnk (k, e) =
-      maybe
-        (throwError $ InsertException undefined)
-        (return . makeUE k e . LinkScale)
-        $ entryRCachedValue e
+
+-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
+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)
+
+makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
+makeLinkUnk (k, e) =
+  maybe
+    (throwError $ InsertException undefined)
+    (return . makeUE k e . LinkScale)
+    $ entryRCachedValue e
 
 splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
-  (Nothing, Just TFixed) -> return $ Left $ makeRoUE e
+splitDeferredValue p = do
+  res <- readDeferredValue p
+  case res of
+    Left _ -> throwError $ InsertException undefined
+    Right x -> return x
+
+readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
+readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
   (Just v, Just TBalance) -> go EVBalance v
   (Just v, Just TPercent) -> go EVPercent v
+  (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   _ -> throwError $ InsertException undefined
   where
-    go c = return . Right . fmap c . makeUE k e
+    go c = return . Right . Right . fmap c . makeUE k e
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
@@ -618,16 +648,40 @@ insertAll ebs = do
     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
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
+  k <- insert $ TransactionR c itxDate itxDescr
+  mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
-    go k tx = do
-      ek <- insertEntry k tx
+    insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
+      let fs = NE.toList iesFromEntries
+      let ts = NE.toList iesToEntries
+      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 ()
 
+insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
+insertEntry
+  k
+  i
+  InsertEntry
+    { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
+    , ieDeferred
+    } =
+    do
+      ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
+      mapM_ (insert_ . TagRelationR ek) eTags
+      return ek
+    where
+      (cval, ctype, deflink) = case ieDeferred of
+        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
+        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
+        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
+        Nothing -> (Nothing, Just TFixed, Nothing)
+
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()
 updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 9df0bc4..516931b 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -44,11 +44,15 @@ TransactionR sql=transactions
     commit CommitRId OnDeleteCascade
     date Day
     description T.Text
-    deferred Bool
     deriving Show Eq
-EntryR sql=entries
+EntrySetR sql=entry_sets
     transaction TransactionRId OnDeleteCascade
     currency CurrencyRId OnDeleteCascade
+    index Int
+    rebalance Bool
+    deriving Show Eq
+EntryR sql=entries
+    entryset EntrySetRId OnDeleteCascade 
     account AccountRId OnDeleteCascade
     memo T.Text
     value Rational
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 31eadd0..474f448 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -459,7 +459,7 @@ data Statement = Statement
   , stmtTxOpts :: !(TxOpts T.Text)
   , stmtSkipLines :: !Natural
   }
-  deriving (Eq, Hashable, Generic, FromDhall)
+  deriving (Eq, Hashable, Generic, FromDhall, Show)
 
 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index c02606d..50e8eb7 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -37,6 +37,7 @@ data ConfigHashes = ConfigHashes
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
 data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
+  deriving (Show)
 
 type CurrencyMap = M.Map CurID CurrencyPrec
 
@@ -50,6 +51,7 @@ data DBState = DBState
   , kmStatementInterval :: !DaySpan
   , kmNewCommits :: ![Int]
   }
+  deriving (Show)
 
 data DBUpdates = DBUpdates
   { duOldCommits :: ![Int]
@@ -79,7 +81,7 @@ data UpdateEntry i v = UpdateEntry
   { ueID :: !i
   , ueAcnt :: !AccountRId
   , ueValue :: !v
-  , ueIndex :: !Int -- TODO this isn't needed for primary entries
+  , ueIndex :: !Int
   }
 
 data CurrencyRound = CurrencyRound CurID Natural
@@ -107,32 +109,27 @@ type UE_RO = UpdateEntry () StaticValue
 
 type UEBalanced = UpdateEntry EntryRId StaticValue
 
-data UpdateEntrySet = UpdateEntrySet
-  { utFrom0 :: !UEBlank
+data UpdateEntrySet f t = UpdateEntrySet
+  { utFrom0 :: !f
   , utTo0 :: !UEBlank
-  , utPairs :: ![(UEUnk, [UELink])]
-  , utFromUnk :: ![UEUnk]
+  , utFromUnk :: ![(UEUnk, [UELink])]
   , utToUnk :: ![UEUnk]
-  , utToUnkLink0 :: ![UELink]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
-  , utTotalValue :: !Rational
+  , utTotalValue :: !t
   }
 
+type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
+
+type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
+
 data EntryBin
-  = ToUpdate UpdateEntrySet
+  = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
   | ToRead ReadEntry
   | ToInsert (Tx TxCommit)
 
-data InsertEntry a c t = InsertEntry
-  { feCurrency :: !c
-  , feIndex :: !Int
-  , feDeferred :: !(Maybe DBDeferred)
-  , feEntry :: !(Entry a Rational t)
-  }
-
 type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
 
 type BalEntry = InsertEntry AcntID CurID TagID
@@ -206,49 +203,75 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-data HalfEntrySet a c t v = HalfEntrySet
-  { hesPrimary :: !(Entry a () t)
-  , hesOther :: ![Entry a v t]
+data HalfEntrySet v0 vN = HalfEntrySet
+  { hesPrimary :: !(Entry AcntID v0 TagID)
+  , hesOther :: ![Entry AcntID vN TagID]
   }
+  deriving (Show)
 
-data EntrySet a c t v v' = EntrySet
-  { esTotalValue :: !v'
-  , esCurrency :: !c
-  , esFrom :: !(HalfEntrySet a c t (EntryValue v))
-  , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
+data EntrySet v0 vp0 vpN vtN = EntrySet
+  { esTotalValue :: !v0
+  , esCurrency :: !CurrencyPrec
+  , esFrom :: !(HalfEntrySet vp0 vpN)
+  , esTo :: !(HalfEntrySet () vtN)
   }
+  deriving (Show)
 
-data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
+type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
+
+type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
+
+type PrimaryEntrySet =
+  TotalEntrySet
+    Rational
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+type SecondayEntrySet =
+  FullEntrySet
+    (EntryValue Rational)
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+type TransferEntrySet = SecondayEntrySet
+
+type ShadowEntrySet =
+  TotalEntrySet
+    Double
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
+  deriving (Eq, Ord, Show)
 
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
-  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
+  , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
+  , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
   }
-  deriving (Generic)
+  deriving (Generic, Show)
+
+data InsertEntry a c t = InsertEntry
+  { ieDeferred :: !(Maybe DBDeferred)
+  , ieEntry :: !(Entry a Rational t)
+  }
+
+data InsertEntrySet = InsertEntrySet
+  { iesCurrency :: !CurrencyRId
+  , iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  , iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  }
 
 data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
-  , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
+  , itxEntrySets :: !(NonEmpty InsertEntrySet)
   , itxCommit :: !TxCommit
   }
   deriving (Generic)
 
-type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational
-
-type BalEntrySet = EntrySet AcntID CurID TagID Rational
-
-type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
-
--- type DeferredTx = Tx [DeferredEntrySet]
-
--- type BalTx = InsertTx [BalEntry]
-
--- type KeyTx = InsertTx [KeyEntry]
-
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 059cd10..84a3dd9 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -64,7 +64,6 @@ module Internal.Utils
   , expandTransfers
   , expandTransfer
   , entryPair
-  , entryPair_
   )
 where
 
@@ -334,20 +333,21 @@ toTx
         , txDescr = trDesc
         , txCommit = ()
         , txPrimary =
-            EntrySet
-              { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
-              , esCurrency = cur
-              , esFrom = f
-              , esTo = t
-              }
-        , txOther = ss
+            Left $
+              EntrySet
+                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
+                , esCurrency = cur
+                , esFrom = f
+                , esTo = t
+                }
+        , txOther = fmap Left ss
         }
     where
       curRes = do
         m <- askDBState kmCurrency
         cur <- liftInner $ resolveCurrency m r tgCurrency
-        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
-        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
+        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
         combineError fromRes toRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
@@ -355,35 +355,37 @@ resolveSubGetter
   :: MonadFinance m
   => TxRecord
   -> TxSubGetter
-  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
+  -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- askDBState kmCurrency
   cur <- liftInner $ resolveCurrency m r tsgCurrency
-  let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
-  let toRes = resolveHalfEntry resolveToValue cur r tsgTo
+  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
   let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
-  liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
-    EntrySet
-      { esTotalValue = Right v
-      , esCurrency = cur
-      , esFrom = f
-      , esTo = t
-      }
+  liftInner $ combineErrorM toRes valRes $ \t v -> do
+    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
+    return $
+      EntrySet
+        { esTotalValue = ()
+        , esCurrency = cur
+        , esFrom = f
+        , esTo = t
+        }
 
 resolveHalfEntry
   :: Traversable f
   => (TxRecord -> n -> InsertExcept (f Double))
   -> CurrencyPrec
   -> TxRecord
+  -> v
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
-resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+  -> InsertExcept (HalfEntrySet v (f Rational))
+resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
       { hesPrimary =
           Entry
             { eAcnt = a
-            , eValue = ()
+            , eValue = v
             , eComment = thgComment
             , eTags = thgTags
             }
@@ -913,10 +915,10 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 --   where
 --     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
 
-groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
 groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+    go xs@((c, _) :| _) = (c, fmap snd xs)
 
 groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
 groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
@@ -1037,56 +1039,54 @@ 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 (ToUpdate utx) =
+      fmap (Just . Left) $
+        liftInnerS $
+          either rebalanceTotalEntrySet rebalanceFullEntrySet 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
+      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
+      let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
+      es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
       let tx =
             InsertTx
               { itxDescr = txDescr
               , itxDate = txDate
-              , itxEntries = concat $ e : es
+              , itxEntrySets = 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
+    fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
 
 binDate :: EntryBin -> Day
-binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
+binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
+binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate
 
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
-data UpdateEntryType a
+data UpdateEntryType a b
   = UET_ReadOnly UE_RO
-  | UET_Unk UEUnk
-  | UET_Linked a
+  | UET_Unk a
+  | UET_Linked b
 
 -- TODO make sure new values are rounded properly here
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
-rebalanceEntrySet
+rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceTotalEntrySet
   UpdateEntrySet
-    { utFrom0
+    { utFrom0 = (f0, f0links)
     , utTo0
-    , utPairs
-    , utFromUnk
+    , -- , utPairs
+    utFromUnk
     , utToUnk
     , utFromRO
     , utToRO
     , utCurrency
-    , utToUnkLink0
-    , utTotalValue
+    , -- , utToUnkLink0
+    utTotalValue
     } =
     do
       (f0val, (tpairs, fs)) <-
@@ -1094,10 +1094,9 @@ rebalanceEntrySet
           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
+                ++ (UET_Linked <$> utFromUnk)
+      let f0' = f0 {ueValue = StaticValue f0val}
+      let tsLink0 = fmap (unlink (-f0val)) f0links
       (t0val, tsUnk) <-
         fmap (second catMaybes) $
           foldM goTo (-utTotalValue, []) $
@@ -1106,7 +1105,7 @@ rebalanceEntrySet
                 ++ (UET_Unk <$> utToUnk)
                 ++ (UET_ReadOnly <$> utToRO)
       let t0 = utTo0 {ueValue = StaticValue t0val}
-      return (f0 : fs ++ (t0 : tsUnk))
+      return (f0' : fs ++ (t0 : tsUnk))
     where
       project f _ _ (UET_ReadOnly e) = f e
       project _ f _ (UET_Unk e) = f e
@@ -1149,13 +1148,126 @@ rebalanceEntrySet
         return v
       unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
 
-balanceEntrySet
+rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceFullEntrySet
+  UpdateEntrySet
+    { utFrom0
+    , utTo0
+    , -- , utPairs
+    utFromUnk
+    , utToUnk
+    , utFromRO
+    , utToRO
+    , utCurrency
+    -- , utToUnkLink0
+    } =
+    do
+      let (f_ro, f_lnkd) = case utFrom0 of
+            Left x -> (x : utFromRO, utFromUnk)
+            Right x -> (utFromRO, x : utFromUnk)
+      (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
+      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
+        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) 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)}
+      entrySum = sum . fmap ueValue
+
+balanceSecondaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
-  -> DeferredEntrySet v
-  -> StateT EntryBals m [KeyEntry]
-balanceEntrySet
-  findTot
+  => SecondayEntrySet
+  -> StateT EntryBals m InsertEntrySet
+balanceSecondaryEntrySet
+  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) curID
+      fs'' <- mapErrors balFromEntry fs'
+      let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
+      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+      ts'' <- mapErrors balToEntry ts'
+      -- TODO wet
+      let (acntID, sign) = eAcnt t0'
+      let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
+      modify (mapAdd_ (acntID, curID) 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)
+
+balancePrimaryEntrySet
+  :: (MonadInsertError m, MonadFinance m)
+  => PrimaryEntrySet
+  -> StateT EntryBals m InsertEntrySet
+balancePrimaryEntrySet
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -1163,53 +1275,48 @@ balanceEntrySet
     , 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
+      let fsres = mapErrors resolveAcntAndTags fs
+      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'
 
-        -- 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))
+          let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
 
-        -- 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'
+          let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+          ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
+          return $
+            InsertEntrySet
+              { iesCurrency = curID
+              , iesFromEntries = fs''
+              , iesToEntries = ts''
+              }
 
 doEntries
   :: (MonadInsertError m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
+  => (Entry (AccountRId, AcntSign) v TagRId -> 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
+  -> 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
+  es' <- mapErrors f es
   let e0val = tot - entrySum es'
   -- TODO not dry
-  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
-  modify (mapAdd_ (eAcnt e, curID) tot)
+  let s = fromIntegral $ sign2Int sign -- NOTE hack
+  modify (mapAdd_ (acntID, curID) e0val)
   let e' =
         InsertEntry
-          { feEntry = e {eValue = s * e0val}
-          , feCurrency = curID
-          , feDeferred = Nothing
-          , feIndex = i0
+          { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
+          , ieDeferred = Nothing
           }
-  return $ e' : es'
+  return $ e' :| es'
   where
-    entrySum = sum . fmap (eValue . feEntry)
+    entrySum = sum . fmap (eValue . ieEntry)
 
 liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
@@ -1248,38 +1355,30 @@ balanceDeferred curID acntID (EntryValue t v) = do
   return (newval, d)
 
 balanceEntry
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadInsertError m)
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
-  -> Int
-  -> Entry AcntID v TagID
+  -> Entry (AccountRId, AcntSign) v TagRId
   -> 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
-        }
+balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
+  let s = fromIntegral $ sign2Int sign
+  (newVal, deferred) <- f acntID eValue
+  modify (mapAdd_ (acntID, curID) newVal)
+  return $
+    InsertEntry
+      { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
+      , ieDeferred = deferred
+      }
 
 resolveAcntAndTags
   :: (MonadInsertError m, MonadFinance m)
   => Entry AcntID v TagID
-  -> m (Entry AccountRId AcntSign TagRId)
+  -> m (Entry (AccountRId, AcntSign) v 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}
+    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
 
 findBalance
   :: AccountRId
@@ -1310,7 +1409,7 @@ expandTransfer
   -> m [Tx TxCommit]
 expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
   txs <- mapErrors go transAmounts
-  return $ filter (inDaySpan bounds . txDate) $ concat txs
+  return $ concat txs
   where
     go
       Amount
@@ -1318,13 +1417,13 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
         , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
         } =
-        withDates pat $ \day -> do
-          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
+        withDates bounds pat $ \day -> do
+          p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
           return
             Tx
               { txCommit = tc
               , txDate = day
-              , txPrimary = p
+              , txPrimary = Right p
               , txOther = []
               , txDescr = desc
               }
@@ -1335,43 +1434,32 @@ entryPair
   -> 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
+  -> v0
+  -> v1
+  -> m (EntrySet v0 v1 v2 v3)
+entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
   cp <- lookupCurrency curid
-  return $ pair cp from to_ (f cp val)
+  return $
+    EntrySet
+      { esCurrency = cp
+      , esTotalValue = totval
+      , esFrom = halfEntry fa fts val1
+      , esTo = halfEntry ta tts ()
+      }
   where
-    halfEntry :: a -> [t] -> HalfEntrySet a c t v
-    halfEntry a ts =
+    halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
+    halfEntry a ts v =
       HalfEntrySet
-        { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
+        { hesPrimary = Entry {eAcnt = a, eValue = v, 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
+  => DaySpan
+  -> DatePat
   -> (Day -> m a)
   -> m [a]
-withDates dp f = do
-  bounds <- askDBState kmBudgetInterval
+withDates bounds dp f = do
   days <- liftExcept $ expandDatePat bounds dp
   combineErrors $ fmap f days

From 8c9dc1e9709ba9dc23959f7be0dfd6710ac0552f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 4 Jul 2023 00:11:25 -0400
Subject: [PATCH 37/59] REF rearrange stuff

---
 app/Main.hs                    |   1 -
 lib/Internal/History.hs        | 241 ++++++++++++++++++++++
 lib/Internal/Types/Database.hs |   1 +
 lib/Internal/Types/Main.hs     |   9 +-
 lib/Internal/Utils.hs          | 360 +--------------------------------
 5 files changed, 251 insertions(+), 361 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index a4847bd..4c61c7b 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -180,7 +180,6 @@ runSync c = do
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
-        -- lift $ print hTs'
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
 
     -- Update the DB.
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 3b7176f..f705d45 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -8,6 +8,7 @@ where
 import Control.Monad.Except
 import Data.Csv
 import Data.Foldable
+import GHC.Real
 import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
@@ -19,6 +20,8 @@ import qualified RIO.Map as M
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
+import Text.Regex.TDFA hiding (matchAll)
+import Text.Regex.TDFA.Text
 
 -- 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
@@ -261,3 +264,241 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchSkip -> (Nothing : matched, unmatched)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
+
+matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
+matches
+  StatementParser {spTx, spOther, spVal, spDate, spDesc}
+  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
+    res <- liftInner $
+      combineError3 val other desc $
+        \x y z -> x && y && z && date
+    if res
+      then maybe (return MatchSkip) convert spTx
+      else return MatchFail
+    where
+      val = valMatches spVal trAmount
+      date = maybe True (`dateMatches` trDate) spDate
+      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
+      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
+      convert tg = MatchPass <$> toTx tg r
+
+toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
+toTx
+  TxGetter
+    { tgFrom
+    , tgTo
+    , tgCurrency
+    , tgOtherEntries
+    , tgScale
+    }
+  r@TxRecord {trAmount, trDate, trDesc} = do
+    combineError curRes subRes $ \(cur, f, t) ss ->
+      Tx
+        { txDate = trDate
+        , txDescr = trDesc
+        , txCommit = ()
+        , txPrimary =
+            Left $
+              EntrySet
+                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
+                , esCurrency = cur
+                , esFrom = f
+                , esTo = t
+                }
+        , txOther = fmap Left ss
+        }
+    where
+      curRes = do
+        m <- askDBState kmCurrency
+        cur <- liftInner $ resolveCurrency m r tgCurrency
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
+        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
+        combineError fromRes toRes (cur,,)
+      subRes = mapErrors (resolveSubGetter r) tgOtherEntries
+
+resolveSubGetter
+  :: MonadFinance m
+  => TxRecord
+  -> TxSubGetter
+  -> InsertExceptT m SecondayEntrySet
+resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
+  m <- askDBState kmCurrency
+  cur <- liftInner $ resolveCurrency m r tsgCurrency
+  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
+  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
+  liftInner $ combineErrorM toRes valRes $ \t v -> do
+    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
+    return $
+      EntrySet
+        { esTotalValue = ()
+        , esCurrency = cur
+        , esFrom = f
+        , esTo = t
+        }
+
+resolveHalfEntry
+  :: Traversable f
+  => (TxRecord -> n -> InsertExcept (f Double))
+  -> CurrencyPrec
+  -> TxRecord
+  -> v
+  -> TxHalfGetter (EntryGetter n)
+  -> InsertExcept (HalfEntrySet v (f Rational))
+resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+  combineError acntRes esRes $ \a es ->
+    HalfEntrySet
+      { hesPrimary =
+          Entry
+            { eAcnt = a
+            , eValue = v
+            , eComment = thgComment
+            , eTags = thgTags
+            }
+      , hesOther = es
+      }
+  where
+    acntRes = resolveAcnt r thgAcnt
+    esRes = mapErrors (resolveEntry f cur r) thgEntries
+
+otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
+otherMatches dict m = case m of
+  Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
+  Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
+  where
+    lookup_ t n = lookupErr (MatchField t) n dict
+
+resolveEntry
+  :: Traversable f
+  => (TxRecord -> n -> InsertExcept (f Double))
+  -> CurrencyPrec
+  -> TxRecord
+  -> EntryGetter n
+  -> InsertExcept (Entry AcntID (f Rational) TagID)
+resolveEntry f cur r s@Entry {eAcnt, eValue} = do
+  combineError acntRes valRes $ \a v ->
+    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
+  where
+    acntRes = resolveAcnt r eAcnt
+    valRes = f r eValue
+
+resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
+resolveFromValue = resolveValue
+
+resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
+resolveToValue _ (Linked l) = return $ LinkIndex l
+resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
+
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
+resolveValue TxRecord {trOther, trAmount} s = case s of
+  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (ConstN c) -> return $ EntryValue TFixed c
+  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
+  BalanceN x -> return $ EntryValue TBalance x
+  PercentN x -> return $ EntryValue TPercent x
+
+resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
+resolveAcnt = resolveEntryField AcntField
+
+resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
+resolveCurrency m r c = do
+  i <- resolveEntryField CurField r c
+  case M.lookup i m of
+    Just k -> return k
+    -- TODO this should be its own error (I think)
+    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
+
+resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
+resolveEntryField t TxRecord {trOther = o} s = case s of
+  ConstT p -> return p
+  LookupT f -> lookup_ f o
+  MapT (Field f m) -> do
+    k <- lookup_ f o
+    lookup_ k m
+  Map2T (Field (f1, f2) m) -> do
+    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
+    lookup_ (k1, k2) m
+  where
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
+    lookup_ = lookupErr (EntryIDField t)
+
+readDouble :: T.Text -> InsertExcept Double
+readDouble s = case readMaybe $ T.unpack s of
+  Just x -> return x
+  Nothing -> throwError $ InsertException [ConversionError s]
+
+readRational :: T.Text -> InsertExcept Rational
+readRational s = case T.split (== '.') s of
+  [x] -> maybe err (return . fromInteger) $ readT x
+  [x, y] -> case (readT x, readT y) of
+    (Just x', Just y') ->
+      let p = 10 ^ T.length y
+          k = if x' >= 0 then 1 else -1
+       in return $ fromInteger x' + k * y' % p
+    _ -> err
+  _ -> err
+  where
+    readT = readMaybe . T.unpack
+    err = throwError $ InsertException [ConversionError s]
+
+compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
+compileOptions o@TxOpts {toAmountFmt = pat} = do
+  re <- compileRegex True pat
+  return $ o {toAmountFmt = re}
+
+compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
+compileMatch m@StatementParser {spDesc, spOther} = do
+  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
+  where
+    go = compileRegex False
+    dres = mapM go spDesc
+    ores = combineErrors $ fmap (mapM go) spOther
+
+compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
+compileRegex groups pat = case res of
+  Right re -> return (pat, re)
+  Left _ -> throwError $ InsertException [RegexError pat]
+  where
+    res =
+      compile
+        (blankCompOpt {newSyntax = True})
+        (blankExecOpt {captureGroups = groups})
+        pat
+
+matchMaybe :: T.Text -> Regex -> InsertExcept Bool
+matchMaybe q re = case execute re q of
+  Right res -> return $ isJust res
+  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
+
+matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
+matchGroupsMaybe q re = case regexec re q of
+  Right Nothing -> []
+  Right (Just (_, _, _, xs)) -> xs
+  -- this should never fail as regexec always returns Right
+  Left _ -> []
+
+parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
+parseRational (pat, re) s = case matchGroupsMaybe s re of
+  [sign, x, ""] -> uncurry (*) <$> readWhole sign x
+  [sign, x, y] -> do
+    d <- readT "decimal" y
+    let p = 10 ^ T.length y
+    (k, w) <- readWhole sign x
+    return $ k * (w + d % p)
+  _ -> msg "malformed decimal"
+  where
+    readT what t = case readMaybe $ T.unpack t of
+      Just d -> return $ fromInteger d
+      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
+    msg :: MonadFail m => T.Text -> m a
+    msg m =
+      fail $
+        T.unpack $
+          T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
+    readSign x
+      | x == "-" = return (-1)
+      | x == "+" || x == "" = return 1
+      | otherwise = msg $ T.append "invalid sign: " x
+    readWhole sign x = do
+      w <- readT "whole number" x
+      k <- readSign sign
+      return (k, w)
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 516931b..a3baab0 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -64,6 +64,7 @@ EntryR sql=entries
 TagRelationR sql=tag_relations
     entry EntryRId OnDeleteCascade
     tag TagRId OnDeleteCascade
+    deriving Show Eq
 BudgetLabelR sql=budget_labels
     entry EntryRId OnDeleteCascade
     budgetName T.Text
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 50e8eb7..6975139 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -76,6 +76,7 @@ data ReadEntry = ReadEntry
   , reValue :: !Rational
   , reDate :: !Day
   }
+  deriving (Show)
 
 data UpdateEntry i v = UpdateEntry
   { ueID :: !i
@@ -83,21 +84,22 @@ data UpdateEntry i v = UpdateEntry
   , ueValue :: !v
   , ueIndex :: !Int
   }
+  deriving (Show)
 
 data CurrencyRound = CurrencyRound CurID Natural
 
 deriving instance Functor (UpdateEntry i)
 
 newtype LinkScale = LinkScale {unLinkScale :: Rational}
-  deriving newtype (Num)
+  deriving newtype (Num, Show)
 
 -- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
 --   deriving newtype (Num)
 
 newtype StaticValue = StaticValue {unStaticValue :: Rational}
-  deriving newtype (Num)
+  deriving newtype (Num, Show)
 
-data EntryValueUnk = EVBalance Rational | EVPercent Rational
+data EntryValueUnk = EVBalance Rational | EVPercent Rational deriving (Show)
 
 type UEUnk = UpdateEntry EntryRId EntryValueUnk
 
@@ -120,6 +122,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utDate :: !Day
   , utTotalValue :: !t
   }
+  deriving (Show)
 
 type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 84a3dd9..10d4ddb 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -5,7 +5,6 @@ module Internal.Utils
   , fromWeekday
   , inDaySpan
   , fmtRational
-  , matches
   , fromGregorian'
   , resolveDaySpan
   , resolveDaySpan_
@@ -28,12 +27,7 @@ module Internal.Utils
   , combineErrorIOM3
   , collectErrorsIO
   , mapErrorsIO
-  , parseRational
   , showError
-  , unlessLeft_
-  , unlessLefts_
-  , unlessLeft
-  , unlessLefts
   , acntPath2Text
   , showT
   , lookupErr
@@ -43,8 +37,6 @@ module Internal.Utils
   , sndOf3
   , thdOf3
   , xGregToDay
-  , compileMatch
-  , compileOptions
   , dateMatches
   , valMatches
   , roundPrecision
@@ -64,6 +56,8 @@ module Internal.Utils
   , expandTransfers
   , expandTransfer
   , entryPair
+  , singleQuote
+  , keyVals
   )
 where
 
@@ -80,8 +74,6 @@ 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
 
 --------------------------------------------------------------------------------
 -- intervals
@@ -300,101 +292,6 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
-matches
-  StatementParser {spTx, spOther, spVal, spDate, spDesc}
-  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    res <- liftInner $
-      combineError3 val other desc $
-        \x y z -> x && y && z && date
-    if res
-      then maybe (return MatchSkip) convert spTx
-      else return MatchFail
-    where
-      val = valMatches spVal trAmount
-      date = maybe True (`dateMatches` trDate) spDate
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
-      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
-      convert tg = MatchPass <$> toTx tg r
-
-toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
-toTx
-  TxGetter
-    { tgFrom
-    , tgTo
-    , tgCurrency
-    , tgOtherEntries
-    , tgScale
-    }
-  r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError curRes subRes $ \(cur, f, t) ss ->
-      Tx
-        { txDate = trDate
-        , txDescr = trDesc
-        , txCommit = ()
-        , txPrimary =
-            Left $
-              EntrySet
-                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
-                , esCurrency = cur
-                , esFrom = f
-                , esTo = t
-                }
-        , txOther = fmap Left ss
-        }
-    where
-      curRes = do
-        m <- askDBState kmCurrency
-        cur <- liftInner $ resolveCurrency m r tgCurrency
-        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
-        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
-        combineError fromRes toRes (cur,,)
-      subRes = mapErrors (resolveSubGetter r) tgOtherEntries
-
-resolveSubGetter
-  :: MonadFinance m
-  => TxRecord
-  -> TxSubGetter
-  -> InsertExceptT m SecondayEntrySet
-resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- askDBState kmCurrency
-  cur <- liftInner $ resolveCurrency m r tsgCurrency
-  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
-  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
-  liftInner $ combineErrorM toRes valRes $ \t v -> do
-    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
-    return $
-      EntrySet
-        { esTotalValue = ()
-        , esCurrency = cur
-        , esFrom = f
-        , esTo = t
-        }
-
-resolveHalfEntry
-  :: Traversable f
-  => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurrencyPrec
-  -> TxRecord
-  -> v
-  -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet v (f Rational))
-resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
-  combineError acntRes esRes $ \a es ->
-    HalfEntrySet
-      { hesPrimary =
-          Entry
-            { eAcnt = a
-            , eValue = v
-            , eComment = thgComment
-            , eTags = thgTags
-            }
-      , hesOther = es
-      }
-  where
-    acntRes = resolveAcnt r thgAcnt
-    esRes = mapErrors (resolveEntry f cur r) thgEntries
-
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
   | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
@@ -412,27 +309,6 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
 dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
-otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
-otherMatches dict m = case m of
-  Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
-  Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
-  where
-    lookup_ t n = lookupErr (MatchField t) n dict
-
-resolveEntry
-  :: Traversable f
-  => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurrencyPrec
-  -> TxRecord
-  -> EntryGetter n
-  -> InsertExcept (Entry AcntID (f Rational) TagID)
-resolveEntry f cur r s@Entry {eAcnt, eValue} = do
-  combineError acntRes valRes $ \a v ->
-    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
-  where
-    acntRes = resolveAcnt r eAcnt
-    valRes = f r eValue
-
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
 
@@ -442,9 +318,6 @@ liftExceptT x = runExceptT x >>= either throwError return
 liftExcept :: MonadError e m => Except e a -> m a
 liftExcept = either throwError return . runExcept
 
--- tryError :: MonadError e m => m a -> m (Either e a)
--- tryError action = (Right <$> action) `catchError` (pure . Left)
-
 liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
 liftIOExceptT = fromEither <=< runExceptT
 
@@ -526,101 +399,11 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
 collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
-resolveFromValue = resolveValue
-
-resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
-resolveToValue _ (Linked l) = return $ LinkIndex l
-resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
-
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
-resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return $ EntryValue TFixed c
-  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
-  BalanceN x -> return $ EntryValue TBalance x
-  PercentN x -> return $ EntryValue TPercent x
-
-resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
-resolveAcnt = resolveEntryField AcntField
-
-resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
-resolveCurrency m r c = do
-  i <- resolveEntryField CurField r c
-  case M.lookup i m of
-    Just k -> return k
-    -- TODO this should be its own error (I think)
-    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
-
-resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
-resolveEntryField t TxRecord {trOther = o} s = case s of
-  ConstT p -> return p
-  LookupT f -> lookup_ f o
-  MapT (Field f m) -> do
-    k <- lookup_ f o
-    lookup_ k m
-  Map2T (Field (f1, f2) m) -> do
-    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
-    lookup_ (k1, k2) m
-  where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
-    lookup_ = lookupErr (EntryIDField t)
-
 lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
 lookupErr what k m = case M.lookup k m of
   Just x -> return x
   _ -> throwError $ InsertException [LookupError what $ showT k]
 
-parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
-parseRational (pat, re) s = case matchGroupsMaybe s re of
-  [sign, x, ""] -> uncurry (*) <$> readWhole sign x
-  [sign, x, y] -> do
-    d <- readT "decimal" y
-    let p = 10 ^ T.length y
-    (k, w) <- readWhole sign x
-    return $ k * (w + d % p)
-  _ -> msg "malformed decimal"
-  where
-    readT what t = case readMaybe $ T.unpack t of
-      Just d -> return $ fromInteger d
-      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
-    msg :: MonadFail m => T.Text -> m a
-    msg m =
-      fail $
-        T.unpack $
-          T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
-    readSign x
-      | x == "-" = return (-1)
-      | x == "+" || x == "" = return 1
-      | otherwise = msg $ T.append "invalid sign: " x
-    readWhole sign x = do
-      w <- readT "whole number" x
-      k <- readSign sign
-      return (k, w)
-
-readDouble :: T.Text -> InsertExcept Double
-readDouble s = case readMaybe $ T.unpack s of
-  Just x -> return x
-  Nothing -> throwError $ InsertException [ConversionError s]
-
-readRational :: T.Text -> InsertExcept Rational
-readRational s = case T.split (== '.') s of
-  [x] -> maybe err (return . fromInteger) $ readT x
-  [x, y] -> case (readT x, readT y) of
-    (Just x', Just y') ->
-      let p = 10 ^ T.length y
-          k = if x' >= 0 then 1 else -1
-       in return $ fromInteger x' + k * y' % p
-    _ -> err
-  _ -> err
-  where
-    readT = readMaybe . T.unpack
-    err = throwError $ InsertException [ConversionError s]
-
--- TODO smells like a lens
--- mapTxSplits :: (a -> b) -> Tx a -> Tx b
--- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
-
 fmtRational :: Natural -> Rational -> T.Text
 fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
   where
@@ -834,87 +617,9 @@ keyVals = T.intercalate "; " . fmap (uncurry keyVal)
 showT :: Show a => a -> T.Text
 showT = T.pack . show
 
---------------------------------------------------------------------------------
--- pure error processing
-
--- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
--- concatEither2 a b fun = case (a, b) of
---   (Right a_, Right b_) -> Right $ fun a_ b_
---   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-
--- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
--- concatEither2M a b fun = case (a, b) of
---   (Right a_, Right b_) -> Right <$> fun a_ b_
---   _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-
--- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
--- concatEither3 a b c fun = case (a, b, c) of
---   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
---   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
-
--- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
--- concatEithers2 a b = merge . concatEither2 a b
-
--- concatEithers2M
---   :: Monad m
---   => Either [x] a
---   -> Either [x] b
---   -> (a -> b -> m c)
---   -> m (Either [x] c)
--- concatEithers2M a b = fmap merge . concatEither2M a b
-
--- concatEithers3
---   :: Either [x] a
---   -> Either [x] b
---   -> Either [x] c
---   -> (a -> b -> c -> d)
---   -> Either [x] d
--- concatEithers3 a b c = merge . concatEither3 a b c
-
--- concatEitherL :: [Either x a] -> Either [x] [a]
--- concatEitherL as = case partitionEithers as of
---   ([], bs) -> Right bs
---   (es, _) -> Left es
-
--- concatEithersL :: [Either [x] a] -> Either [x] [a]
--- concatEithersL = merge . concatEitherL
-
--- leftToMaybe :: Either a b -> Maybe a
--- leftToMaybe (Left a) = Just a
--- leftToMaybe _ = Nothing
-
-unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
-unlessLeft (Left es) _ = return (return es)
-unlessLeft (Right rs) f = f rs
-
-unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
-unlessLefts (Left es) _ = return es
-unlessLefts (Right rs) f = f rs
-
-unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
-unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
-
-unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
-unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
-
--- plural :: Either a b -> Either [a] b
--- plural = first (: [])
-
--- merge :: Either [[a]] b -> Either [a] b
--- merge = first concat
-
 --------------------------------------------------------------------------------
 -- random functions
 
--- when bifunctor fails...
--- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
--- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
-
--- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
--- groupKey f = fmap go . NE.groupAllWith (f . fst)
---   where
---     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
-
 groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
 groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
@@ -940,65 +645,6 @@ sndOf3 (_, b, _) = b
 thdOf3 :: (a, b, c) -> c
 thdOf3 (_, _, c) = c
 
--- lpad :: a -> Int -> [a] -> [a]
--- lpad c n s = replicate (n - length s) c ++ s
-
--- rpad :: a -> Int -> [a] -> [a]
--- rpad c n s = s ++ replicate (n - length s) c
-
--- lpadT :: Char -> Int -> T.Text -> T.Text
--- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
-
--- TODO this regular expression appears to be compiled each time, which is
--- super slow
--- NOTE: see https://github.com/haskell-hvr/regex-tdfa/issues/9 - performance
--- is likely not going to be optimal for text
--- matchMaybe :: T.Text -> T.Text -> EitherErr Bool
--- matchMaybe q pat = case compres of
---   Right re -> case execute re q of
---     Right res -> Right $ isJust res
---     Left _ -> Left $ RegexError "this should not happen"
---   Left _ -> Left $ RegexError pat
---   where
---     -- these options barely do anything in terms of performance
---     compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat
-
-compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
-compileOptions o@TxOpts {toAmountFmt = pat} = do
-  re <- compileRegex True pat
-  return $ o {toAmountFmt = re}
-
-compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
-compileMatch m@StatementParser {spDesc, spOther} = do
-  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
-  where
-    go = compileRegex False
-    dres = mapM go spDesc
-    ores = combineErrors $ fmap (mapM go) spOther
-
-compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
-compileRegex groups pat = case res of
-  Right re -> return (pat, re)
-  Left _ -> throwError $ InsertException [RegexError pat]
-  where
-    res =
-      compile
-        (blankCompOpt {newSyntax = True})
-        (blankExecOpt {captureGroups = groups})
-        pat
-
-matchMaybe :: T.Text -> Regex -> InsertExcept Bool
-matchMaybe q re = case execute re q of
-  Right res -> return $ isJust res
-  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
-
-matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
-matchGroupsMaybe q re = case regexec re q of
-  Right Nothing -> []
-  Right (Just (_, _, _, xs)) -> xs
-  -- this should never fail as regexec always returns Right
-  Left _ -> []
-
 lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
 lookupAccount = lookupFinance AcntField kmAccount
 
@@ -1339,7 +985,7 @@ balanceLinked from curID precision acntID lg = case lg of
       Nothing -> throwError undefined
   (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
   where
-    go s = roundPrecision precision . (* s) . fromRational
+    go s = negate . roundPrecision precision . (* s) . fromRational
 
 balanceDeferred
   :: CurrencyRId

From d9709f565faa0307411bcc9f04cdff60c719539d Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 4 Jul 2023 10:35:11 -0400
Subject: [PATCH 38/59] FIX separate running totals by budget label

---
 lib/Internal/Budget.hs         | 38 +++++++------
 lib/Internal/Database.hs       | 33 +++++++-----
 lib/Internal/History.hs        | 12 +++--
 lib/Internal/Types/Database.hs |  5 +-
 lib/Internal/Types/Main.hs     | 12 ++---
 lib/Internal/Utils.hs          | 97 +++++++++++++++++++---------------
 6 files changed, 110 insertions(+), 87 deletions(-)

diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index c635fbb..eeb7215 100644
--- 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
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index a376588..b4d3199 100644
--- 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
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index f705d45..806d716 100644
--- 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"
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index a3baab0..f83fc34 100644
--- 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
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 6975139..42964f9 100644
--- 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)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 10d4ddb..742c660 100644
--- 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

From dce3ff4166228610f7fac7578154a7ed63968884 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Wed, 5 Jul 2023 22:30:24 -0400
Subject: [PATCH 39/59] ENH clean up (and hopefully fix) lots of balancing
 stuff

---
 lib/Internal/Database.hs   |  56 +++---
 lib/Internal/Types/Main.hs |  15 +-
 lib/Internal/Utils.hs      | 382 +++++++++++++++++--------------------
 3 files changed, 211 insertions(+), 242 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index b4d3199..a0472f4 100644
--- 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) =
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 42964f9..bc2e868 100644
--- 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
 
 --------------------------------------------------------------------------------
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 742c660..b156ea6 100644
--- 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
-            Left x -> (x : utFromRO, utFromUnk)
-            Right x -> (utFromRO, x : utFromUnk)
-      (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))
+      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
+      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
+      return (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 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
+      (rs, ls) = case utFrom0 of
+        Left x -> (x : utFromRO, utFromUnk)
+        Right x -> (utFromRO, x : utFromUnk)
+      bc = (utCurrency, utBudget)
 
-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)
+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 $
+          (Left <$> ro) ++ (Right <$> linked)
+  return (tot, fs, tpairs)
+  where
+    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' = 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, 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
-          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'
-          return $
-            InsertEntrySet
-              { iesCurrency = curID
-              , iesFromEntries = fs''
-              , iesToEntries = 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'
+      }
 
 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, [])

From 24bc9a239bf8f061300f90c78f6ba40982ec892d Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 6 Jul 2023 00:05:16 -0400
Subject: [PATCH 40/59] FIX rounding errors

---
 app/Main.hs                | 14 ++++++++++
 lib/Internal/Database.hs   | 19 +++++++++-----
 lib/Internal/Types/Main.hs |  2 +-
 lib/Internal/Utils.hs      | 52 ++++++++++++++++++++------------------
 4 files changed, 55 insertions(+), 32 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 4c61c7b..60c403e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -178,17 +178,31 @@ runSync c = do
       flip runReaderT state $ do
         let (hTs, hSs) = splitHistory $ statements config
         hSs' <- mapErrorsIO (readHistStmt root) hSs
+        -- lift $ print $ length $ lefts hSs'
+        -- lift $ print $ length $ rights hSs'
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
+        -- lift $ print $ length $ lefts hTs'
         bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
+        -- lift $ print $ length $ lefts bTs
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
+    -- print $ length $ kmNewCommits state
+    -- print $ length $ duOldCommits updates
+    -- print $ length $ duNewTagIds updates
+    -- print $ length $ duNewAcntPaths updates
+    -- print $ length $ duNewAcntIds updates
+    -- print $ length $ duNewCurrencyIds updates
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       -- NOTE this must come first (unless we defer foreign keys)
       updateDBState updates
+      -- TODO skip this entire section if the database won't change (eg length
+      -- of 'is' is zero and there are no commits to delete)
       res <- runExceptT $ do
         -- TODO taking out the hash is dumb
         (rs, ues) <- readUpdates $ fmap commitRHash rus
+        -- rerunnableIO $ print ues
+        -- rerunnableIO $ print $ length rs
         let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
         insertAll ebs
       -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index a0472f4..d680f0f 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -428,7 +428,7 @@ readUpdates
   -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
 readUpdates hashes = do
   xs <- selectE $ do
-    (commits :& txs :& entrysets :& entries) <-
+    (commits :& txs :& entrysets :& entries :& currencies) <-
       E.from
         $ E.table @CommitR
           `E.innerJoin` E.table @TransactionR
@@ -437,6 +437,8 @@ readUpdates hashes = do
         `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table @EntryR
         `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
+          `E.innerJoin` E.table @CurrencyR
+        `E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
     return
       ( entrysets ^. EntrySetRRebalance
@@ -445,7 +447,10 @@ readUpdates hashes = do
           ( entrysets ^. EntrySetRId
           , txs ^. TransactionRDate
           , txs ^. TransactionRBudgetName
-          , entrysets ^. EntrySetRCurrency
+          ,
+            ( entrysets ^. EntrySetRCurrency
+            , currencies ^. CurrencyRPrecision
+            )
           )
         , entries
         )
@@ -454,7 +459,7 @@ readUpdates hashes = do
   toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate)
   return (makeRE . snd <$> toRead, toUpdate')
   where
-    makeUES ((_, day, name, curID), es) = do
+    makeUES ((_, day, name, (curID, prec)), es) = do
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -471,7 +476,7 @@ readUpdates hashes = do
               Left $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -485,7 +490,7 @@ readUpdates hashes = do
               Right $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -496,7 +501,7 @@ readUpdates hashes = do
                   , utBudget = E.unValue name
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, curID), entry) =
+    makeRE ((_, day, name, (curID, _)), entry) =
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
@@ -671,7 +676,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
 --   BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
 --   _ -> return ()
 
-insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
+insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId
 insertEntry
   k
   i
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index bc2e868..fb01374 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -120,7 +120,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utToUnk :: ![UEUnk]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
-  , utCurrency :: !CurrencyRId
+  , utCurrency :: !(CurrencyRId, Natural)
   , utDate :: !Day
   , utTotalValue :: !t
   , utBudget :: !T.Text
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index b156ea6..fea403b 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -733,19 +733,19 @@ rebalanceTotalEntrySet
     , utToUnk
     , utFromRO
     , utToRO
-    , utCurrency
+    , utCurrency = (curID, precision)
     , utTotalValue
     , utBudget
     } =
     do
-      (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
+      (fval, fs, tpairs) <- rebalanceDebit bc precision 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
+      ts <- rebalanceCredit bc precision utTotalValue utTo0 utToUnk utToRO tsLinked
       return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
     where
-      bc = (utCurrency, utBudget)
+      bc = (curID, utBudget)
 
 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@@ -756,25 +756,26 @@ rebalanceFullEntrySet
     , utToUnk
     , utFromRO
     , utToRO
-    , utCurrency
+    , utCurrency = (curID, precision)
     , utBudget
     } =
     do
-      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
-      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
+      (ftot, fs, tpairs) <- rebalanceDebit bc precision rs ls
+      ts <- rebalanceCredit bc precision ftot utTo0 utToUnk utToRO tpairs
       return (fs ++ ts)
     where
       (rs, ls) = case utFrom0 of
         Left x -> (x : utFromRO, utFromUnk)
         Right x -> (utFromRO, x : utFromUnk)
-      bc = (utCurrency, utBudget)
+      bc = (curID, utBudget)
 
 rebalanceDebit
   :: BCKey
+  -> Natural
   -> [UE_RO]
   -> [(UEUnk, [UELink])]
   -> State EntryBals (Rational, [UEBalanced], [UEBalanced])
-rebalanceDebit k ro linked = do
+rebalanceDebit k precision ro linked = do
   (tot, (tpairs, fs)) <-
     fmap (second (partitionEithers . concat)) $
       sumM goFrom $
@@ -785,7 +786,7 @@ rebalanceDebit k ro linked = do
     idx = either ueIndex (ueIndex . fst)
     goFrom (Left e) = (,[]) <$> updateFixed k e
     goFrom (Right (e0, es)) = do
-      v <- updateUnknown k e0
+      v <- updateUnknown precision k e0
       let e0' = Right $ e0 {ueValue = StaticValue v}
       let es' = Left . unlink v <$> es
       return (v, e0' : es')
@@ -795,13 +796,14 @@ unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
 
 rebalanceCredit
   :: BCKey
+  -> Natural
   -> Rational
   -> UEBlank
   -> [UEUnk]
   -> [UE_RO]
   -> [UEBalanced]
   -> State EntryBals [UEBalanced]
-rebalanceCredit k tot t0 us rs bs = do
+rebalanceCredit k precision tot t0 us rs bs = do
   (tval, ts) <-
     fmap (second catMaybes) $
       sumM goTo $
@@ -815,7 +817,7 @@ rebalanceCredit k tot t0 us rs bs = do
     goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
     goTo (UETLinked e) = (,Just e) <$> updateFixed k e
     goTo (UETUnk e) = do
-      v <- updateUnknown k e
+      v <- updateUnknown precision k e
       return (v, Just $ e {ueValue = StaticValue v})
 
 data UpdateEntryType a b
@@ -834,11 +836,11 @@ updateFixed k e = do
   modify $ mapAdd_ (ueAcnt e, k) v
   return v
 
-updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
-updateUnknown k e = do
+updateUnknown :: Natural -> BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
+updateUnknown precision k e = do
   let key = (ueAcnt e, k)
   curBal <- gets (M.findWithDefault 0 key)
-  let v = case ueValue e of
+  let v = roundPrecision precision $ fromRational $ case ueValue e of
         EVPercent p -> p * curBal
         EVBalance p -> p - curBal
   modify $ mapAdd_ key v
@@ -868,7 +870,7 @@ balancePrimaryEntrySet
       let bc = (curID, budgetName)
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
-          let balFrom = fmap liftInnerS . balanceDeferred
+          let balFrom = fmap liftInnerS . balanceDeferred precision
           fs'' <- doEntries balFrom bc esTotalValue f0' fs'
           balanceFinal bc (-esTotalValue) precision fs'' t0' ts'
 
@@ -894,7 +896,7 @@ balanceSecondaryEntrySet
         balanceFinal bc (-tot) precision fs'' t0' ts'
     where
       entrySum = sum . fmap (eValue . ieEntry)
-      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
+      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred precision) bc
       bc = (curID, budgetName)
 
 balanceFinal
@@ -958,16 +960,17 @@ balanceLinked from precision k 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 k d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred precision k d
   where
     go s = negate . roundPrecision precision . (* s) . fromRational
 
 balanceDeferred
-  :: ABCKey
+  :: Natural
+  -> ABCKey
   -> EntryValue Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred k (EntryValue t v) = do
-  newval <- findBalance k t v
+balanceDeferred prec k (EntryValue t v) = do
+  newval <- findBalance prec k t v
   let d = case t of
         TFixed -> Nothing
         TBalance -> Just $ EntryBalance v
@@ -1001,13 +1004,14 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
     \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
 
 findBalance
-  :: ABCKey
+  :: Natural
+  -> ABCKey
   -> TransferType
   -> Rational
   -> State EntryBals Rational
-findBalance k t v = do
+findBalance prec k t v = do
   curBal <- gets (M.findWithDefault 0 k)
-  return $ case t of
+  return $ roundPrecision prec $ fromRational $ case t of
     TBalance -> v - curBal
     TPercent -> v * curBal
     TFixed -> v

From 2946a8f9e2bbfc42382248aadd1b2de4b66bceb7 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 7 Jul 2023 00:20:18 -0400
Subject: [PATCH 41/59] ADD priority flag to keep tx's sorted always

---
 dhall/Types.dhall              |   4 +-
 lib/Internal/Budget.hs         | 115 ++++++++++++++++-----------------
 lib/Internal/Database.hs       |  14 ++--
 lib/Internal/History.hs        |  10 +--
 lib/Internal/Types/Database.hs |   1 +
 lib/Internal/Types/Dhall.hs    |   1 +
 lib/Internal/Types/Main.hs     |   4 ++
 lib/Internal/Utils.hs          |  16 +++--
 8 files changed, 89 insertions(+), 76 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index a48121e..fd6a45a 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -679,7 +679,7 @@ let Amount =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { amtWhen : w, amtValue : v, amtDesc : Text }
+        { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
 
 let TransferType =
     {-
@@ -967,11 +967,13 @@ let Income =
               (if any) after all allocations have been applied.
               -}
               TaggedAcnt.Type
+          , incPriority : Integer
           }
       , default =
         { incPretax = [] : List (SingleAllocation PretaxValue)
         , incTaxes = [] : List (SingleAllocation TaxValue)
         , incPosttaxx = [] : List (SingleAllocation PosttaxValue)
+        , incPriority = +0
         }
       }
 
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index eeb7215..035a49e 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -92,29 +92,30 @@ readIncome
   Income
     { incWhen
     , incCurrency
-    , incFrom
+    , incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
     , incPretax
     , incPosttax
     , incTaxes
-    , incToBal
+    , incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
     , incGross
     , incPayPeriod
+    , incPriority
     } =
     combineErrorM
       (combineError incRes nonIncRes (,))
-      (combineError precRes dayRes (,))
-      $ \_ (precision, days) -> do
-        let gross = roundPrecision precision incGross
-        concat <$> foldDays (allocate precision gross) start days
+      (combineError cpRes dayRes (,))
+      $ \_ (cp, days) -> do
+        let gross = roundPrecisionCur cp incGross
+        foldDays (allocate cp gross) start days
     where
-      incRes = isIncomeAcnt $ taAcnt incFrom
+      incRes = isIncomeAcnt srcAcnt
       nonIncRes =
         mapErrors isNotIncomeAcnt $
-          taAcnt incToBal
+          destAcnt
             : (alloAcnt <$> incPretax)
             ++ (alloAcnt <$> incTaxes)
             ++ (alloAcnt <$> incPosttax)
-      precRes = lookupCurrencyPrec incCurrency
+      cpRes = lookupCurrency incCurrency
       dayRes = liftExcept $ expandDatePat ds incWhen
       start = fromGregorian' $ pStart incPayPeriod
       pType' = pType incPayPeriod
@@ -123,8 +124,9 @@ readIncome
       flatPost = concatMap flattenAllo incPosttax
       sumAllos = sum . fmap faValue
       -- TODO ensure these are all the "correct" accounts
-      allocate precision gross prevDay day = do
+      allocate cp gross prevDay day = do
         scaler <- liftExcept $ periodScaler pType' prevDay day
+        let precision = cpPrec cp
         let (preDeductions, pre) =
               allocatePre precision gross $
                 flatPre ++ concatMap (selectAllos day) intPre
@@ -135,31 +137,39 @@ readIncome
         let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-        let balance = aftertaxGross - sumAllos post
         -- TODO double or rational here?
-        primary <-
-          entryPair
-            incFrom
-            incToBal
-            incCurrency
-            "balance after deductions"
-            (fromRational balance)
-            ()
-        -- TODO make this into one large tx?
-        allos <- mapErrors (allo2Trans key name day incFrom) (pre ++ tax ++ post)
-        let bal =
-              Tx
-                { txCommit = key
-                , txDate = day
-                , txPrimary = Left primary
-                , txOther = []
-                , txDescr = "balance after deductions"
-                , txBudget = name
+        let src =
+              Entry
+                { eAcnt = srcAcnt
+                , eValue = ()
+                , eComment = ""
+                , eTags = srcTags
                 }
-        -- TODO use real name here
-        if balance < 0
-          then throwError $ InsertException [IncomeError day name balance]
-          else return (bal : allos)
+        let dest =
+              Entry
+                { eAcnt = destAcnt
+                , eValue = ()
+                , eComment = "balance after deductions"
+                , eTags = destTags
+                }
+        let allos = allo2Trans <$> (pre ++ tax ++ post)
+        let primary =
+              EntrySet
+                { esTotalValue = gross
+                , esCurrency = cp
+                , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
+                , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
+                }
+        return $
+          Tx
+            { txCommit = key
+            , txDate = day
+            , txPrimary = Left primary
+            , txOther = []
+            , txDescr = ""
+            , txBudget = name
+            , txPriority = incPriority
+            }
 
 periodScaler
   :: PeriodType
@@ -236,49 +246,35 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
       | otherwise = throwError $ InsertException [AccountError i ts]
 
 flattenAllo :: SingleAllocation v -> [FlatAllocation v]
-flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
+flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = alloCur
-        , faTo = alloTo
+        { faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
 -- ASSUME allocations are sorted
 selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
-selectAllos day Allocation {alloAmts, alloCur, alloTo} =
+selectAllos day Allocation {alloAmts, alloTo} =
   go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = alloCur
-        , faTo = alloTo
+        { faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
-allo2Trans
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
-  -> Day
-  -> TaggedAcnt
-  -> FlatAllocation Rational
-  -> 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
-    Tx
-      { txCommit = meta
-      , txDate = day
-      , txPrimary = Left p
-      , txOther = []
-      , txDescr = faDesc
-      , txBudget = name
-      }
+allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID
+allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
+  Entry
+    { eValue = LinkDeferred (EntryValue TFixed faValue)
+    , eComment = faDesc
+    , eAcnt = taAcnt
+    , eTags = taTags
+    }
 
 allocatePre
   :: Natural
@@ -414,6 +410,5 @@ data FlatAllocation v = FlatAllocation
   { faValue :: !v
   , faDesc :: !T.Text
   , faTo :: !TaggedAcnt
-  , faCur :: !CurID
   }
   deriving (Functor, Show)
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index d680f0f..c050ba5 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -447,6 +447,7 @@ readUpdates hashes = do
           ( entrysets ^. EntrySetRId
           , txs ^. TransactionRDate
           , txs ^. TransactionRBudgetName
+          , txs ^. TransactionRPriority
           ,
             ( entrysets ^. EntrySetRCurrency
             , currencies ^. CurrencyRPrecision
@@ -456,10 +457,10 @@ readUpdates hashes = do
         )
       )
   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, name, (curID, prec)), es) = do
+    makeUES ((_, day, name, pri, (curID, prec)), es) = do
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -485,6 +486,7 @@ readUpdates hashes = do
                   , utToUnk = toUnk
                   , utTotalValue = tot
                   , utBudget = E.unValue name
+                  , utPriority = E.unValue pri
                   }
             Right x ->
               Right $
@@ -499,9 +501,10 @@ readUpdates hashes = do
                   , utToUnk = toUnk
                   , utTotalValue = ()
                   , utBudget = E.unValue name
+                  , utPriority = E.unValue pri
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, (curID, _)), entry) =
+    makeRE ((_, day, name, pri, (curID, _)), entry) =
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
@@ -509,6 +512,7 @@ readUpdates hashes = do
             , reAcnt = entryRAccount e
             , reValue = entryRValue e
             , reBudget = E.unValue name
+            , rePriority = E.unValue pri
             }
 
 splitFrom
@@ -660,8 +664,8 @@ insertAll ebs = do
 --   getCommit (BudgetCommit c _) = c
 
 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
-  k <- insert $ TransactionR c itxDate itxDescr itxBudget
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
+  k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
   mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 806d716..8727424 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -267,7 +267,7 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
 matches
-  StatementParser {spTx, spOther, spVal, spDate, spDesc}
+  StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
     res <- liftInner $
       combineError3 val other desc $
@@ -280,10 +280,11 @@ matches
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
-      convert tg = MatchPass <$> toTx tg r
+      convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
 
-toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
+toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
 toTx
+  priority
   TxGetter
     { tgFrom
     , tgTo
@@ -305,8 +306,9 @@ toTx
                 , esFrom = f
                 , esTo = t
                 }
-        , txOther = fmap Left ss
+        , txOther = Left <$> ss
         , txBudget = historyName
+        , txPriority = priority
         }
     where
       curRes = do
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index f83fc34..b3f4564 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -45,6 +45,7 @@ TransactionR sql=transactions
     date Day
     description T.Text
     budgetName T.Text
+    priority Int
     deriving Show Eq
 EntrySetR sql=entry_sets
     transaction TransactionRId OnDeleteCascade
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 474f448..08d63a1 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -243,6 +243,7 @@ data Income = Income
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
   , incPayPeriod :: !Period
+  , incPriority :: !Int
   }
 
 deriving instance Hashable HourlyPeriod
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index fb01374..bc8b4e9 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -76,6 +76,7 @@ data ReadEntry = ReadEntry
   , reAcnt :: !AccountRId
   , reValue :: !Rational
   , reDate :: !Day
+  , rePriority :: !Int
   , reBudget :: !T.Text
   }
   deriving (Show)
@@ -124,6 +125,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utDate :: !Day
   , utTotalValue :: !t
   , utBudget :: !T.Text
+  , utPriority :: !Int
   }
   deriving (Show)
 
@@ -245,6 +247,7 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
+  , txPriority :: !Int
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
@@ -266,6 +269,7 @@ data InsertEntrySet = InsertEntrySet
 data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
+  , itxPriority :: !Int
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
   , itxCommit :: !CommitR
   , itxBudget :: !T.Text
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index fea403b..e7e4b69 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -692,7 +692,7 @@ balanceTxs ebs =
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
       modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
       e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
       es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
@@ -704,15 +704,17 @@ balanceTxs ebs =
               , itxEntrySets = e :| es
               , itxCommit = txCommit
               , itxBudget = txBudget
+              , itxPriority = txPriority
               }
       return $ Just $ Right tx
     fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
 
-binDate :: EntryBin -> Day
-binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
-binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
-binDate (ToRead ReadEntry {reDate}) = reDate
-binDate (ToInsert Tx {txDate}) = txDate
+binDate :: EntryBin -> (Day, Int)
+binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
+binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
+binDate (ToUpdate u) = either go go u
+  where
+    go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
 
 type BCKey = (CurrencyRId, Text)
 
@@ -1044,6 +1046,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         { amtWhen = pat
         , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
+        , amtPriority = pri
         } =
         withDates bounds pat $ \day -> do
           p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
@@ -1055,6 +1058,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
               , txOther = []
               , txDescr = desc
               , txBudget = name
+              , txPriority = fromIntegral pri
               }
 
 entryPair

From 00346ff8ee3a2b016628551189cc13cbc69bc71b Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 7 Jul 2023 20:20:09 -0400
Subject: [PATCH 42/59] ENH clean up types a bit

---
 dhall/Types.dhall           | 94 +++++++++++++++++++------------------
 dhall/common.dhall          |  2 +-
 lib/Internal/Types/Dhall.hs | 36 +++++++-------
 3 files changed, 68 insertions(+), 64 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index fd6a45a..e3bdd2a 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -280,49 +280,50 @@ let DatePat =
 
 let TxOpts =
     {- Additional metadata to use when parsing a statement -}
-      { Type =
-          { toDate :
-              {-
-              Column title for date
-              -}
-              Text
-          , toAmount :
-              {-
-              Column title for amount
-              -}
-              Text
-          , toDesc :
-              {-
-              Column title for description
-              -}
-              Text
-          , toOther :
-              {-
-              Titles of other columns to include; these will be available in
-              a map for use in downstream processing (see 'Field')
-              -}
-              List Text
-          , toDateFmt :
-              {-
-              Format of the date field as specified in the
-              Data.Time.Format.formattime Haskell function.
-              -}
-              Text
-          , toAmountFmt :
-              {- Format of the amount field. Must include three fields for the
-              sign, numerator, and denominator of the amount.
-              -}
-              Text
+      \(re : Type) ->
+        { Type =
+            { toDate :
+                {-
+                Column title for date
+                -}
+                Text
+            , toAmount :
+                {-
+                Column title for amount
+                -}
+                Text
+            , toDesc :
+                {-
+                Column title for description
+                -}
+                Text
+            , toOther :
+                {-
+                Titles of other columns to include; these will be available in
+                a map for use in downstream processing (see 'Field')
+                -}
+                List Text
+            , toDateFmt :
+                {-
+                Format of the date field as specified in the
+                Data.Time.Format.formattime Haskell function.
+                -}
+                Text
+            , toAmountFmt :
+                {- Format of the amount field. Must include three fields for the
+                sign, numerator, and denominator of the amount.
+                -}
+                re
+            }
+        , default =
+          { toDate = "Date"
+          , toAmount = "Amount"
+          , toDesc = "Description"
+          , toOther = [] : List Text
+          , toDateFmt = "%0m/%0d/%Y"
+          , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
           }
-      , default =
-        { toDate = "Date"
-        , toAmount = "Amount"
-        , toDesc = "Description"
-        , toOther = [] : List Text
-        , toDateFmt = "%0m/%0d/%Y"
-        , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
         }
-      }
 
 let Field =
     {-
@@ -679,7 +680,10 @@ let Amount =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
+        { Type =
+            { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
+        , default.amtPriority = +0
+        }
 
 let TransferType =
     {-
@@ -711,7 +715,7 @@ let Transfer =
         { transFrom : a
         , transTo : a
         , transCurrency : c
-        , transAmounts : List (Amount w v)
+        , transAmounts : List (Amount w v).Type
         }
 
 let TaggedAcnt =
@@ -748,7 +752,7 @@ let Statement =
         file delimiter as a numeric char, usually either tab (9) or comma (44)
         -}
         : Natural
-      , stmtTxOpts : TxOpts.Type
+      , stmtTxOpts : (TxOpts Text).Type
       , stmtSkipLines
         {-
         how many lines to skip before parsing statement
@@ -771,7 +775,7 @@ let Allocation =
       \(w : Type) ->
       \(v : Type) ->
         { alloTo : TaggedAcnt.Type
-        , alloAmts : List (Amount w v)
+        , alloAmts : List (Amount w v).Type
         , alloCur :
             {-TODO allow exchanges here-}
             CurID
diff --git a/dhall/common.dhall b/dhall/common.dhall
index 0283bb6..e38136a 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -9,7 +9,7 @@ let nullEntry =
       \(v : T.EntryNumGetter) ->
         T.FromEntryGetter::{ eAcnt = a, eValue = v }
 
-let nullOpts = T.TxOpts::{=}
+let nullOpts = (T.TxOpts Text)::{=}
 
 let nullVal = T.ValMatcher::{=}
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 08d63a1..10b0bce 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -19,7 +19,6 @@ import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.Text as T
--- import RIO.Time
 import Text.Regex.TDFA
 
 makeHaskellTypesWith
@@ -49,12 +48,18 @@ makeHaskellTypesWith
   , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
   , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
   , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
-  , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
+  , SingleConstructor
+      "Amount"
+      "Amount"
+      "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
+  , SingleConstructor
+      "TxOpts"
+      "TxOpts"
+      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts re).Type"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
   , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
-  , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
-    SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
+  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
   , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
   , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
   , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
@@ -64,11 +69,6 @@ makeHaskellTypesWith
   , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
   , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
   , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-  -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-  -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
-  -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-  -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-  -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
   ]
 
 deriveProduct
@@ -443,15 +443,15 @@ deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
 
 deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
 
-data TxOpts re = TxOpts
-  { toDate :: !T.Text
-  , toAmount :: !T.Text
-  , toDesc :: !T.Text
-  , toOther :: ![T.Text]
-  , toDateFmt :: !T.Text
-  , toAmountFmt :: !re
-  }
-  deriving (Eq, Generic, Hashable, Show, FromDhall)
+deriving instance Eq a => Eq (TxOpts a)
+
+deriving instance Generic (TxOpts a)
+
+deriving instance Hashable a => Hashable (TxOpts a)
+
+deriving instance FromDhall a => FromDhall (TxOpts a)
+
+deriving instance Show a => Show (TxOpts a)
 
 data Statement = Statement
   { stmtPaths :: ![FilePath]

From 90b88945c58a57d311c77a2d185144b250bad437 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 7 Jul 2023 20:42:41 -0400
Subject: [PATCH 43/59] ENH clean up types again

---
 dhall/Types.dhall           | 16 +++++++++++++--
 dhall/common.dhall          | 41 ++++++++++++-------------------------
 lib/Internal/Types/Dhall.hs |  2 +-
 3 files changed, 28 insertions(+), 31 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index e3bdd2a..606e5d4 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -278,7 +278,7 @@ let DatePat =
     -}
       < Cron : CronPat.Type | Mod : ModPat.Type >
 
-let TxOpts =
+let TxOpts_ =
     {- Additional metadata to use when parsing a statement -}
       \(re : Type) ->
         { Type =
@@ -325,6 +325,8 @@ let TxOpts =
           }
         }
 
+let TxOpts = TxOpts_ Text
+
 let Field =
     {-
     General key-value type
@@ -732,6 +734,8 @@ let HistTransfer =
     -}
       Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
 
+let TransferAmount = Amount DatePat TransferValue.Type
+
 let Statement =
     {-
     How to import a statement from local file(s). Statements are assumed to be
@@ -752,7 +756,7 @@ let Statement =
         file delimiter as a numeric char, usually either tab (9) or comma (44)
         -}
         : Natural
-      , stmtTxOpts : (TxOpts Text).Type
+      , stmtTxOpts : TxOpts.Type
       , stmtSkipLines
         {-
         how many lines to skip before parsing statement
@@ -874,6 +878,8 @@ let SingleAllocation =
     -}
       Allocation {}
 
+let SingleAlloAmount = \(v : Type) -> Amount {} v
+
 let MultiAllocation =
     {-
     An allocation specialized to capturing multiple income streams within a given
@@ -882,6 +888,8 @@ let MultiAllocation =
     -}
       Allocation Interval
 
+let MultiAlloAmount = \(v : Type) -> Amount Interval v
+
 let HourlyPeriod =
     {-
     Definition for a pay period denominated in hours
@@ -1120,6 +1128,7 @@ in  { CurID
     , CronPat
     , DatePat
     , TxOpts
+    , TxOpts_
     , StatementParser
     , StatementParser_
     , ValMatcher
@@ -1171,4 +1180,7 @@ in  { CurID
     , HourlyPeriod
     , Period
     , PeriodType
+    , TransferAmount
+    , MultiAlloAmount
+    , SingleAlloAmount
     }
diff --git a/dhall/common.dhall b/dhall/common.dhall
index e38136a..a8ca0ab 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -9,14 +9,6 @@ let nullEntry =
       \(v : T.EntryNumGetter) ->
         T.FromEntryGetter::{ eAcnt = a, eValue = v }
 
-let nullOpts = (T.TxOpts Text)::{=}
-
-let nullVal = T.ValMatcher::{=}
-
-let nullMatch = T.StatementParser::{=}
-
-let nullCron = T.CronPat::{=}
-
 let nullMod =
       \(by : Natural) ->
       \(u : T.TimeUnit) ->
@@ -27,18 +19,17 @@ let cron1 =
       \(m : Natural) ->
       \(d : Natural) ->
         T.DatePat.Cron
-          (     nullCron
-            //  { cpYear = Some (T.MDYPat.Single y)
-                , cpMonth = Some (T.MDYPat.Single m)
-                , cpDay = Some (T.MDYPat.Single d)
-                }
-          )
+          T.CronPat::{
+          , cpYear = Some (T.MDYPat.Single y)
+          , cpMonth = Some (T.MDYPat.Single m)
+          , cpDay = Some (T.MDYPat.Single d)
+          }
 
-let matchInf_ = nullMatch
+let matchInf_ = T.StatementParser::{=}
 
-let matchInf = \(x : T.TxGetter.Type) -> nullMatch // { spTx = Some x }
+let matchInf = \(x : T.TxGetter.Type) -> T.StatementParser::{ spTx = Some x }
 
-let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
+let matchN_ = \(n : Natural) -> T.StatementParser::{ spTimes = Some n }
 
 let matchN =
       \(n : Natural) ->
@@ -120,13 +111,13 @@ let addDay =
       \(d : Natural) ->
         { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
 
-let mvP = nullVal // { vmSign = Some True }
+let mvP = T.ValMatcher::{ vmSign = Some True }
 
-let mvN = nullVal // { vmSign = Some False }
+let mvN = T.ValMatcher::{ vmSign = Some False }
 
-let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
+let mvNum = \(x : Natural) -> T.ValMatcher::{ vmNum = Some x }
 
-let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
+let mvDen = \(x : Natural) -> T.ValMatcher::{ vmDen = Some x }
 
 let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
 
@@ -136,13 +127,7 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
 
 let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
 
-in      { nullEntry
-        , nullMatch
-        , nullVal
-        , nullOpts
-        , nullCron
-        , nullMod
-        , cron1
+in      { cron1
         , mY
         , mYM
         , mYMD
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 10b0bce..b2ca0c6 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -55,7 +55,7 @@ makeHaskellTypesWith
   , SingleConstructor
       "TxOpts"
       "TxOpts"
-      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts re).Type"
+      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
   , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"

From c886c53f171c8a9e1a0e24787362b70d0933c976 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 7 Jul 2023 20:50:55 -0400
Subject: [PATCH 44/59] FIX readd export

---
 dhall/common.dhall | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index a8ca0ab..9c1ee71 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -156,5 +156,7 @@ in      { cron1
         , mvDenP
         , mvDenN
         , PartEntry
+        , nullEntry
+        , nullMod
         }
     /\  T

From 46decdc4de18597d8ac1d462d47f3ca0e05fc7ad Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 8 Jul 2023 00:52:40 -0400
Subject: [PATCH 45/59] ENH use decimals to round

---
 budget.cabal               |   6 +-
 lib/Internal/Budget.hs     |  90 ++++++++----------
 lib/Internal/Database.hs   |  79 ++++++++-------
 lib/Internal/History.hs    | 109 +++++++++++++--------
 lib/Internal/Types/Main.hs |  67 +++++--------
 lib/Internal/Utils.hs      | 190 ++++++++++++++++++-------------------
 package.yaml               |   1 +
 7 files changed, 277 insertions(+), 265 deletions(-)

diff --git a/budget.cabal b/budget.cabal
index aa0f2b3..428696b 100644
--- a/budget.cabal
+++ b/budget.cabal
@@ -75,7 +75,8 @@ library
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
   build-depends:
-      base >=4.12 && <10
+      Decimal >=0.5.2
+    , base >=4.12 && <10
     , cassava
     , conduit >=1.3.4.2
     , containers >=0.6.4.1
@@ -144,7 +145,8 @@ executable pwncash
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
   build-depends:
-      base >=4.12 && <10
+      Decimal >=0.5.2
+    , base >=4.12 && <10
     , budget
     , cassava
     , conduit >=1.3.4.2
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 035a49e..ad685f9 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -1,6 +1,7 @@
 module Internal.Budget (readBudget) where
 
 import Control.Monad.Except
+import Data.Decimal hiding (allocate)
 import Data.Foldable
 import Internal.Database
 import Internal.Types.Main
@@ -105,7 +106,7 @@ readIncome
       (combineError incRes nonIncRes (,))
       (combineError cpRes dayRes (,))
       $ \_ (cp, days) -> do
-        let gross = roundPrecisionCur cp incGross
+        let gross = realFracToDecimal (cpPrec cp) incGross
         foldDays (allocate cp gross) start days
     where
       incRes = isIncomeAcnt srcAcnt
@@ -156,7 +157,7 @@ readIncome
         let primary =
               EntrySet
                 { esTotalValue = gross
-                , esCurrency = cp
+                , esCurrency = cpID cp
                 , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
                 , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
                 }
@@ -178,18 +179,16 @@ periodScaler
   -> InsertExcept PeriodScaler
 periodScaler pt prev cur = return scale
   where
-    n = fromIntegral $ workingDays wds prev cur
+    n = workingDays wds prev cur
     wds = case pt of
       Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
       Daily ds -> ds
-    scale precision x = case pt of
+    scale prec x = case pt of
       Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        fromRational (rnd $ x / fromIntegral hpAnnualHours)
+        realFracToDecimal prec (x / fromIntegral hpAnnualHours)
           * fromIntegral hpDailyHours
-          * n
-      Daily _ -> x * n / 365.25
-      where
-        rnd = roundPrecision precision
+          * fromIntegral n
+      Daily _ -> realFracToDecimal prec (x * fromIntegral n / 365.25)
 
 -- ASSUME start < end
 workingDays :: [Weekday] -> Day -> Day -> Natural
@@ -267,49 +266,44 @@ selectAllos day Allocation {alloAmts, alloTo} =
         , faDesc = amtDesc
         }
 
-allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID
+allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
 allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
   Entry
-    { eValue = LinkDeferred (EntryValue TFixed faValue)
+    { eValue = LinkDeferred (EntryFixed faValue)
     , eComment = faDesc
     , eAcnt = taAcnt
     , eTags = taTags
     }
 
 allocatePre
-  :: Natural
-  -> Rational
+  :: Precision
+  -> Decimal
   -> [FlatAllocation PretaxValue]
-  -> (M.Map T.Text Rational, [FlatAllocation Rational])
+  -> (M.Map T.Text Decimal, [FlatAllocation Decimal])
 allocatePre precision gross = L.mapAccumR go M.empty
   where
-    go m f@FlatAllocation {faValue} =
-      let c = preCategory faValue
-          p = preValue faValue
-          v =
-            if prePercent faValue
-              then (roundPrecision 3 p / 100) * gross
-              else roundPrecision precision p
-       in (mapAdd_ c v m, f {faValue = v})
+    go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
+      let v =
+            if prePercent
+              then gross *. (preValue / 100)
+              else realFracToDecimal precision preValue
+       in (mapAdd_ preCategory v m, f {faValue = v})
 
 allocateTax
-  :: Natural
-  -> Rational
-  -> M.Map T.Text Rational
+  :: Precision
+  -> Decimal
+  -> M.Map T.Text Decimal
   -> PeriodScaler
   -> [FlatAllocation TaxValue]
-  -> [FlatAllocation Rational]
+  -> [FlatAllocation Decimal]
 allocateTax precision gross preDeds f = fmap (fmap go)
   where
     go TaxValue {tvCategories, tvMethod} =
       let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
        in case tvMethod of
-            TMPercent p ->
-              roundPrecision precision $
-                fromRational $
-                  roundPrecision 3 p / 100 * agi
+            TMPercent p -> agi *. p / 100
             TMBracket TaxProgression {tpDeductible, tpBrackets} ->
-              let taxDed = roundPrecision precision $ f precision tpDeductible
+              let taxDed = f precision tpDeductible
                in foldBracket f precision (agi - taxDed) tpBrackets
 
 -- | Compute effective tax percentage of a bracket
@@ -323,26 +317,25 @@ allocateTax precision gross preDeds f = fmap (fmap go)
 --
 -- In reality, this can all be done with one loop, but it isn't clear these
 -- three steps are implemented from this alone.
-foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
-foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
+foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
   where
     go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
-      let l = roundPrecision precision $ f precision tbLowerLimit
-          p = roundPrecision 3 tbPercent / 100
-       in if remain >= l then (acc + p * (remain - l), l) else a
+      let l = f prec tbLowerLimit
+       in if remain >= l
+            then (acc + (remain - l) *. (tbPercent / 100), l)
+            else a
 
 allocatePost
-  :: Natural
-  -> Rational
+  :: Precision
+  -> Decimal
   -> [FlatAllocation PosttaxValue]
-  -> [FlatAllocation Rational]
-allocatePost precision aftertax = fmap (fmap go)
+  -> [FlatAllocation Decimal]
+allocatePost prec aftertax = fmap (fmap go)
   where
-    go PosttaxValue {postValue, postPercent} =
-      let v = postValue
-       in if postPercent
-            then aftertax * roundPrecision 3 v / 100
-            else roundPrecision precision v
+    go PosttaxValue {postValue, postPercent}
+      | postPercent = aftertax *. (postValue / 100)
+      | otherwise = realFracToDecimal prec postValue
 
 --------------------------------------------------------------------------------
 -- shadow transfers
@@ -365,8 +358,9 @@ fromShadow
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
+  cp <- lookupCurrency stCurrency
   res <- liftExcept $ shadowMatches stMatch tx
-  es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
+  let es = entryPair stFrom stTo (cpID cp) stDesc stRatio ()
   return $ if not res then Nothing else Just es
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
@@ -374,7 +368,7 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
   -- NOTE this will only match against the primary entry set since those
   -- are what are guaranteed to exist from a transfer
   valRes <- case txPrimary of
-    Left es -> valMatches tmVal $ esTotalValue es
+    Left es -> valMatches tmVal $ toRational $ esTotalValue es
     Right _ -> return True
   return $
     memberMaybe fa tmFrom
@@ -404,7 +398,7 @@ type IntAllocations =
 
 type DaySpanAllocation = Allocation DaySpan
 
-type PeriodScaler = Natural -> Double -> Double
+type PeriodScaler = Precision -> Double -> Decimal
 
 data FlatAllocation v = FlatAllocation
   { faValue :: !v
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index c050ba5..0209355 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -22,6 +22,7 @@ where
 import Conduit
 import Control.Monad.Except
 import Control.Monad.Logger
+import Data.Decimal
 import Data.Hashable
 import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
 import qualified Database.Esqueleto.Experimental as E
@@ -461,6 +462,7 @@ readUpdates hashes = do
   return (makeRE . snd <$> toRead, toUpdate')
   where
     makeUES ((_, day, name, pri, (curID, prec)), es) = do
+      let prec' = fromIntegral $ E.unValue prec
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -469,22 +471,22 @@ readUpdates hashes = do
       case res of
         (Just froms, Just tos) -> do
           let tot = sum $ fmap (entryRValue . snd) froms
-          (from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
-          (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
+          (from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
+          (from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
           -- TODO WAP (wet ass programming)
           return $ case from0' of
             Left x ->
               Left $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
+                  , utCurrency = E.unValue curID
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
                   , utToRO = toRO
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
-                  , utTotalValue = tot
+                  , utTotalValue = realFracToDecimal prec' tot
                   , utBudget = E.unValue name
                   , utPriority = E.unValue pri
                   }
@@ -492,7 +494,7 @@ readUpdates hashes = do
               Right $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
+                  , utCurrency = E.unValue curID
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -504,32 +506,34 @@ readUpdates hashes = do
                   , utPriority = E.unValue pri
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, pri, (curID, _)), entry) =
+    makeRE ((_, day, name, pri, (curID, prec)), entry) =
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
             , reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
-            , reValue = entryRValue e
+            , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
             , reBudget = E.unValue name
             , rePriority = E.unValue pri
             }
 
 splitFrom
-  :: NonEmpty (EntryRId, EntryR)
+  :: Precision
+  -> NonEmpty (EntryRId, EntryR)
   -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
-splitFrom (f0 :| fs) = do
+splitFrom prec (f0 :| fs) = do
   -- ASSUME entries are sorted by index
   -- TODO combine errors here
-  let f0Res = readDeferredValue f0
-  let fsRes = mapErrors splitDeferredValue fs
+  let f0Res = readDeferredValue prec f0
+  let fsRes = mapErrors (splitDeferredValue prec) fs
   combineErrorM f0Res fsRes $ \f0' fs' -> do
     let (ro, unk) = partitionEithers fs'
     -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
     return (f0', ro, unk)
 
 splitTo
-  :: Either UEBlank (Either UE_RO UEUnk)
+  :: Precision
+  -> Either UEBlank (Either UE_RO UEUnk)
   -> [UEUnk]
   -> NonEmpty (EntryRId, EntryR)
   -> InsertExcept
@@ -539,7 +543,7 @@ splitTo
       , [UE_RO]
       , [UEUnk]
       )
-splitTo from0 fromUnk (t0 :| ts) = do
+splitTo prec from0 fromUnk (t0 :| ts) = do
   -- How to split the credit side of the database transaction in 1024 easy
   -- steps:
   --
@@ -547,7 +551,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
   let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
 
   -- 2. For unlinked entries, split into read-only and unknown entries
-  let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
+  let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
 
   -- 3. For linked entries, split into those that link to the primary debit
   --    entry and not
@@ -557,7 +561,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
   --    into those that link to an unknown debit entry or not. Those that
   --    are not will be read-only and those that are will be collected with
   --    their linked debit entry
-  let linkedRes = zipPaired fromUnk linkedN
+  let linkedRes = zipPaired prec fromUnk linkedN
 
   -- 5. For entries linked to the primary debit entry, turn them into linked
   --    entries (lazily only used when needed later)
@@ -571,7 +575,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
     \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
       let (from0', toROLinked0) = case from0 of
             Left blnk -> (Left (blnk, from0Links), [])
-            Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0)
+            Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
             Right (Right unk) -> (Right $ Right (unk, from0Links), [])
       return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
   where
@@ -583,10 +587,11 @@ splitTo from0 fromUnk (t0 :| ts) = do
 -- sorted according to index and 'fst' respectively. NOTE the output will NOT be
 -- sorted.
 zipPaired
-  :: [UEUnk]
+  :: Precision
+  -> [UEUnk]
   -> [(Int, NonEmpty (EntryRId, EntryR))]
   -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
-zipPaired = go ([], [])
+zipPaired prec = go ([], [])
   where
     nolinks = ((,[]) <$>)
     go acc fs [] = return $ first (nolinks fs ++) acc
@@ -599,7 +604,7 @@ zipPaired = go ([], [])
               | otherwise -> (Nothing, rest)
             _ -> (Nothing, rest)
       let acc' = (nolinks lesser ++ facc, tacc)
-      let ros = NE.toList $ makeRoUE . snd <$> tls
+      let ros = NE.toList $ makeRoUE prec . snd <$> tls
       let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
       go (f acc') fs' ts
 
@@ -619,30 +624,30 @@ makeLinkUnk (k, e) =
   maybe
     (throwError $ InsertException undefined)
     (return . makeUE k e . LinkScale)
-    $ entryRCachedValue e
+    $ fromRational <$> entryRCachedValue e
 
-splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue p = do
-  res <- readDeferredValue p
+splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
+splitDeferredValue prec p = do
+  res <- readDeferredValue prec p
   case res of
     Left _ -> throwError $ InsertException undefined
     Right x -> return x
 
-readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
-readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
-  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
-  (Just v, Just TBalance) -> go EVBalance v
-  (Just v, Just TPercent) -> go EVPercent v
+readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
+readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
+  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal prec v
+  (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
   (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   _ -> throwError $ InsertException undefined
   where
-    go c = return . Right . Right . fmap c . makeUE k e
+    go = return . Right . Right
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
 
-makeRoUE :: EntryR -> UpdateEntry () StaticValue
-makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
+makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
+makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal prec $ entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
@@ -689,15 +694,17 @@ insertEntry
     , ieDeferred
     } =
     do
-      ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
+      ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
       mapM_ (insert_ . TagRelationR ek) eTags
       return ek
     where
       (cval, ctype, deflink) = case ieDeferred of
-        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
-        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
-        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
+        (Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
+        (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
+        (Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
         Nothing -> (Nothing, Just TFixed, Nothing)
 
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
+  where
+    v = toRational $ unStaticValue ueValue
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 8727424..5cef870 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -7,6 +7,7 @@ where
 
 import Control.Monad.Except
 import Data.Csv
+import Data.Decimal
 import Data.Foldable
 import GHC.Real
 import Internal.Database
@@ -93,7 +94,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
   if d == ""
     then return Nothing
     else do
-      a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
+      a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
       e <- r .: T.encodeUtf8 toDesc
       os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
@@ -276,7 +277,7 @@ matches
       then maybe (return MatchSkip) convert spTx
       else return MatchFail
     where
-      val = valMatches spVal trAmount
+      val = valMatches spVal $ toRational trAmount
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
@@ -301,8 +302,8 @@ toTx
         , txPrimary =
             Left $
               EntrySet
-                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
-                , esCurrency = cur
+                { esTotalValue = roundTo (cpPrec cur) trAmount *. tgScale
+                , esCurrency = cpID cur
                 , esFrom = f
                 , esTo = t
                 }
@@ -314,8 +315,9 @@ toTx
       curRes = do
         m <- askDBState kmCurrency
         cur <- liftInner $ resolveCurrency m r tgCurrency
-        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
-        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
+        let prec = cpPrec cur
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
+        let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
         combineError fromRes toRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
@@ -327,27 +329,27 @@ resolveSubGetter
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- askDBState kmCurrency
   cur <- liftInner $ resolveCurrency m r tsgCurrency
-  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
-  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
+  let prec = cpPrec cur
+  let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
+  let valRes = liftInner $ resolveValue prec r tsgValue
   liftInner $ combineErrorM toRes valRes $ \t v -> do
-    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
+    f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
     return $
       EntrySet
         { esTotalValue = ()
-        , esCurrency = cur
+        , esCurrency = cpID cur
         , esFrom = f
         , esTo = t
         }
 
 resolveHalfEntry
-  :: Traversable f
-  => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurrencyPrec
+  :: (Precision -> TxRecord -> n -> InsertExcept v')
+  -> Precision
   -> TxRecord
   -> v
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet v (f Rational))
-resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+  -> InsertExcept (HalfEntrySet v v')
+resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
       { hesPrimary =
@@ -361,7 +363,7 @@ resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntrie
       }
   where
     acntRes = resolveAcnt r thgAcnt
-    esRes = mapErrors (resolveEntry f cur r) thgEntries
+    esRes = mapErrors (resolveEntry f prec r) thgEntries
 
 otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
 otherMatches dict m = case m of
@@ -371,33 +373,33 @@ otherMatches dict m = case m of
     lookup_ t n = lookupErr (MatchField t) n dict
 
 resolveEntry
-  :: Traversable f
-  => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurrencyPrec
+  :: (Precision -> TxRecord -> n -> InsertExcept v)
+  -> Precision
   -> TxRecord
   -> EntryGetter n
-  -> InsertExcept (Entry AcntID (f Rational) TagID)
-resolveEntry f cur r s@Entry {eAcnt, eValue} = do
-  combineError acntRes valRes $ \a v ->
-    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
+  -> InsertExcept (Entry AcntID v TagID)
+resolveEntry f prec r s@Entry {eAcnt, eValue} =
+  combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
   where
     acntRes = resolveAcnt r eAcnt
-    valRes = f r eValue
+    valRes = f prec r eValue
 
-resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
+resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
 resolveFromValue = resolveValue
 
-resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
-resolveToValue _ (Linked l) = return $ LinkIndex l
-resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
+resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
+resolveToValue _ _ (Linked l) = return $ LinkIndex l
+resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
-resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return $ EntryValue TFixed c
-  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
-  BalanceN x -> return $ EntryValue TBalance x
-  PercentN x -> return $ EntryValue TPercent x
+resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
+resolveValue prec TxRecord {trOther, trAmount} s = case s of
+  (LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (ConstN c) -> return $ EntryFixed $ go c
+  AmountN m -> return $ EntryFixed $ trAmount *. m
+  BalanceN x -> return $ EntryBalance $ go x
+  PercentN x -> return $ EntryPercent x
+  where
+    go = realFracToDecimal prec
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
@@ -479,14 +481,41 @@ matchGroupsMaybe q re = case regexec re q of
   -- this should never fail as regexec always returns Right
   Left _ -> []
 
-parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
-parseRational (pat, re) s = case matchGroupsMaybe s re of
-  [sign, x, ""] -> uncurry (*) <$> readWhole sign x
+-- parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
+-- parseRational (pat, re) s = case matchGroupsMaybe s re of
+--   [sign, x, ""] -> uncurry (*) <$> readWhole sign x
+--   [sign, x, y] -> do
+--     d <- readT "decimal" y
+--     let p = 10 ^ T.length y
+--     (k, w) <- readWhole sign x
+--     return $ k * (w + d % p)
+--   _ -> msg "malformed decimal"
+--   where
+--     readT what t = case readMaybe $ T.unpack t of
+--       Just d -> return $ fromInteger d
+--       _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
+--     msg :: MonadFail m => T.Text -> m a
+--     msg m =
+--       fail $
+--         T.unpack $
+--           T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
+--     readSign x
+--       | x == "-" = return (-1)
+--       | x == "+" || x == "" = return 1
+--       | otherwise = msg $ T.append "invalid sign: " x
+--     readWhole sign x = do
+--       w <- readT "whole number" x
+--       k <- readSign sign
+--       return (k, w)
+
+parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
+parseDecimal (pat, re) s = case matchGroupsMaybe s re of
+  [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
   [sign, x, y] -> do
     d <- readT "decimal" y
-    let p = 10 ^ T.length y
+    let p = T.length y
     (k, w) <- readWhole sign x
-    return $ k * (w + d % p)
+    return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
   _ -> msg "malformed decimal"
   where
     readT what t = case readMaybe $ T.unpack t of
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index bc8b4e9..7ac50db 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -12,6 +12,7 @@ module Internal.Types.Main
 where
 
 import Control.Monad.Except
+import Data.Decimal
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Dhall hiding (embed, maybe)
 import Internal.Types.Database
@@ -36,7 +37,7 @@ data ConfigHashes = ConfigHashes
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
-data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
+data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
   deriving (Show)
 
 type CurrencyMap = M.Map CurID CurrencyPrec
@@ -64,17 +65,15 @@ data DBUpdates = DBUpdates
 
 type CurrencyM = Reader CurrencyMap
 
--- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
-
 data DBDeferred
-  = EntryLinked Natural Rational
-  | EntryBalance Rational
-  | EntryPercent Rational
+  = DBEntryLinked Natural Double
+  | DBEntryBalance Decimal
+  | DBEntryPercent Double
 
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
   , reAcnt :: !AccountRId
-  , reValue :: !Rational
+  , reValue :: !Decimal
   , reDate :: !Day
   , rePriority :: !Int
   , reBudget :: !T.Text
@@ -93,16 +92,15 @@ data CurrencyRound = CurrencyRound CurID Natural
 
 deriving instance Functor (UpdateEntry i)
 
-newtype LinkScale = LinkScale {unLinkScale :: Rational}
+type Precision = Word8
+
+newtype LinkScale = LinkScale {unLinkScale :: Decimal}
   deriving newtype (Num, Show)
 
--- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
---   deriving newtype (Num)
-
-newtype StaticValue = StaticValue {unStaticValue :: Rational}
+newtype StaticValue = StaticValue {unStaticValue :: Decimal}
   deriving newtype (Num, Show)
 
-data EntryValueUnk = EVBalance Rational | EVPercent Rational deriving (Show)
+data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
 
 type UEUnk = UpdateEntry EntryRId EntryValueUnk
 
@@ -121,7 +119,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utToUnk :: ![UEUnk]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
-  , utCurrency :: !(CurrencyRId, Natural)
+  , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !t
   , utBudget :: !T.Text
@@ -129,7 +127,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   }
   deriving (Show)
 
-type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
+type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
 
 type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
 
@@ -171,7 +169,7 @@ data AcntPath = AcntPath
 
 data TxRecord = TxRecord
   { trDate :: !Day
-  , trAmount :: !Rational
+  , trAmount :: !Decimal
   , trDesc :: !T.Text
   , trOther :: !(M.Map T.Text T.Text)
   , trFile :: !FilePath
@@ -211,7 +209,7 @@ data HalfEntrySet v0 vN = HalfEntrySet
 
 data EntrySet v0 vp0 vpN vtN = EntrySet
   { esTotalValue :: !v0
-  , esCurrency :: !CurrencyPrec
+  , esCurrency :: !CurrencyRId
   , esFrom :: !(HalfEntrySet vp0 vpN)
   , esTo :: !(HalfEntrySet () vtN)
   }
@@ -221,25 +219,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
 
 type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
 
-type PrimaryEntrySet =
-  TotalEntrySet
-    Rational
-    (EntryValue Rational)
-    (LinkDeferred Rational)
+type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
 
-type SecondayEntrySet =
-  FullEntrySet
-    (EntryValue Rational)
-    (EntryValue Rational)
-    (LinkDeferred Rational)
+type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
 
 type TransferEntrySet = SecondayEntrySet
 
-type ShadowEntrySet =
-  TotalEntrySet
-    Double
-    (EntryValue Rational)
-    (LinkDeferred Rational)
+type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
 
 data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
@@ -257,7 +243,7 @@ data Tx k = Tx
 
 data InsertEntry = InsertEntry
   { ieDeferred :: !(Maybe DBDeferred)
-  , ieEntry :: !(Entry AccountRId Rational TagRId)
+  , ieEntry :: !(Entry AccountRId Decimal TagRId)
   }
 
 data InsertEntrySet = InsertEntrySet
@@ -279,17 +265,16 @@ data InsertTx = InsertTx
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
-data EntryValue a = EntryValue TransferType a
+data EntryValue_ a = EntryValue_ TransferType a
   deriving (Show, Functor, Foldable, Traversable)
 
-data LinkDeferred a
-  = LinkDeferred (EntryValue a)
+data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
+  deriving (Show, Eq, Ord)
+
+data LinkDeferred
+  = LinkDeferred EntryValue
   | LinkIndex LinkedNumGetter
-  deriving (Show, Functor, Traversable, Foldable)
-
--- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-
--- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
+  deriving (Show)
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index e7e4b69..bf6168f 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -39,8 +39,6 @@ module Internal.Utils
   , xGregToDay
   , dateMatches
   , valMatches
-  , roundPrecision
-  , roundPrecisionCur
   , lookupAccount
   , lookupAccountKey
   , lookupAccountSign
@@ -63,6 +61,7 @@ where
 
 import Control.Monad.Error.Class
 import Control.Monad.Except
+import Data.Decimal
 import Data.Time.Format.ISO8601
 import GHC.Real
 import Internal.Types.Main
@@ -415,13 +414,13 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
-roundPrecision :: Natural -> Double -> Rational
-roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
-  where
-    p = 10 ^ n
+-- roundPrecision :: Natural -> Double -> Rational
+-- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
+--   where
+--     p = 10 ^ n
 
-roundPrecisionCur :: CurrencyPrec -> Double -> Rational
-roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
+-- roundPrecisionCur :: CurrencyPrec -> Double -> Rational
+-- roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -525,7 +524,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
     keyVals
       [ ("path", T.pack f)
       , ("date", T.pack $ iso8601Show d)
-      , ("value", showT (fromRational v :: Float))
+      , ("value", showT v)
       , ("description", doubleQuote e)
       ]
 
@@ -663,7 +662,7 @@ lookupCurrency = lookupFinance CurField kmCurrency
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
 
-lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
+lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
@@ -695,7 +694,7 @@ balanceTxs ebs =
     go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
       e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
-      es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
+      es <- mapErrors (goOther tot) txOther
       let tx =
             -- TODO this is lame
             InsertTx
@@ -707,7 +706,12 @@ balanceTxs ebs =
               , itxPriority = txPriority
               }
       return $ Just $ Right tx
-    fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
+      where
+        goOther tot =
+          either
+            (balanceSecondaryEntrySet txBudget)
+            (balancePrimaryEntrySet txBudget . fromShadow tot)
+        fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
 binDate :: EntryBin -> (Day, Int)
 binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
@@ -720,7 +724,7 @@ type BCKey = (CurrencyRId, Text)
 
 type ABCKey = (AccountRId, BCKey)
 
-type EntryBals = M.Map ABCKey Rational
+type EntryBals = M.Map ABCKey Decimal
 
 --------------------------------------------------------------------------------
 -- rebalancing
@@ -735,19 +739,19 @@ rebalanceTotalEntrySet
     , utToUnk
     , utFromRO
     , utToRO
-    , utCurrency = (curID, precision)
+    , utCurrency
     , utTotalValue
     , utBudget
     } =
     do
-      (fval, fs, tpairs) <- rebalanceDebit bc precision utFromRO utFromUnk
+      (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 precision utTotalValue utTo0 utToUnk utToRO tsLinked
+      ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
       return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
     where
-      bc = (curID, utBudget)
+      bc = (utCurrency, utBudget)
 
 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@@ -758,26 +762,25 @@ rebalanceFullEntrySet
     , utToUnk
     , utFromRO
     , utToRO
-    , utCurrency = (curID, precision)
+    , utCurrency
     , utBudget
     } =
     do
-      (ftot, fs, tpairs) <- rebalanceDebit bc precision rs ls
-      ts <- rebalanceCredit bc precision ftot utTo0 utToUnk utToRO tpairs
+      (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)
-      bc = (curID, utBudget)
+      bc = (utCurrency, utBudget)
 
 rebalanceDebit
   :: BCKey
-  -> Natural
   -> [UE_RO]
   -> [(UEUnk, [UELink])]
-  -> State EntryBals (Rational, [UEBalanced], [UEBalanced])
-rebalanceDebit k precision ro linked = do
+  -> State EntryBals (Decimal, [UEBalanced], [UEBalanced])
+rebalanceDebit k ro linked = do
   (tot, (tpairs, fs)) <-
     fmap (second (partitionEithers . concat)) $
       sumM goFrom $
@@ -788,24 +791,23 @@ rebalanceDebit k precision ro linked = do
     idx = either ueIndex (ueIndex . fst)
     goFrom (Left e) = (,[]) <$> updateFixed k e
     goFrom (Right (e0, es)) = do
-      v <- updateUnknown precision k e0
+      v <- updateUnknown k e0
       let e0' = Right $ e0 {ueValue = StaticValue v}
       let es' = Left . unlink v <$> es
       return (v, e0' : es')
 
-unlink :: Rational -> UELink -> UEBalanced
+unlink :: Decimal -> UELink -> UEBalanced
 unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
 
 rebalanceCredit
   :: BCKey
-  -> Natural
-  -> Rational
+  -> Decimal
   -> UEBlank
   -> [UEUnk]
   -> [UE_RO]
   -> [UEBalanced]
   -> State EntryBals [UEBalanced]
-rebalanceCredit k precision tot t0 us rs bs = do
+rebalanceCredit k tot t0 us rs bs = do
   (tval, ts) <-
     fmap (second catMaybes) $
       sumM goTo $
@@ -819,7 +821,7 @@ rebalanceCredit k precision tot t0 us rs bs = do
     goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
     goTo (UETLinked e) = (,Just e) <$> updateFixed k e
     goTo (UETUnk e) = do
-      v <- updateUnknown precision k e
+      v <- updateUnknown k e
       return (v, Just $ e {ueValue = StaticValue v})
 
 data UpdateEntryType a b
@@ -832,18 +834,18 @@ 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 :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Decimal
 updateFixed k e = do
   let v = unStaticValue $ ueValue e
   modify $ mapAdd_ (ueAcnt e, k) v
   return v
 
-updateUnknown :: Natural -> BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
-updateUnknown precision k e = do
+updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Decimal
+updateUnknown k e = do
   let key = (ueAcnt e, k)
   curBal <- gets (M.findWithDefault 0 key)
-  let v = roundPrecision precision $ fromRational $ case ueValue e of
-        EVPercent p -> p * curBal
+  let v = case ueValue e of
+        EVPercent p -> curBal *. p
         EVBalance p -> p - curBal
   modify $ mapAdd_ key v
   return v
@@ -861,7 +863,7 @@ balancePrimaryEntrySet
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
-    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+    , esCurrency
     , esTotalValue
     } =
     do
@@ -869,12 +871,12 @@ balancePrimaryEntrySet
       let t0res = resolveAcntAndTags t0
       let fsres = mapErrors resolveAcntAndTags fs
       let tsres = mapErrors resolveAcntAndTags ts
-      let bc = (curID, budgetName)
+      let bc = (esCurrency, budgetName)
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
-          let balFrom = fmap liftInnerS . balanceDeferred precision
+          let balFrom = fmap liftInnerS . balanceDeferred
           fs'' <- doEntries balFrom bc esTotalValue f0' fs'
-          balanceFinal bc (-esTotalValue) precision fs'' t0' ts'
+          balanceFinal bc (-esTotalValue) fs'' t0' ts'
 
 balanceSecondaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
@@ -886,7 +888,7 @@ balanceSecondaryEntrySet
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
-    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+    , esCurrency
     } =
     do
       let fsRes = mapErrors resolveAcntAndTags (f0 :| fs)
@@ -895,24 +897,23 @@ balanceSecondaryEntrySet
       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'
+        balanceFinal bc (-tot) fs'' t0' ts'
     where
       entrySum = sum . fmap (eValue . ieEntry)
-      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred precision) bc
-      bc = (curID, budgetName)
+      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
+      bc = (esCurrency, budgetName)
 
 balanceFinal
   :: (MonadInsertError m)
   => BCKey
-  -> Rational
-  -> Natural
+  -> Decimal
   -> NonEmpty InsertEntry
   -> Entry (AccountRId, AcntSign) () TagRId
-  -> [Entry (AccountRId, AcntSign) (LinkDeferred Rational) TagRId]
+  -> [Entry (AccountRId, AcntSign) LinkDeferred TagRId]
   -> StateT EntryBals m InsertEntrySet
-balanceFinal k@(curID, _) tot precision fs t0 ts = do
+balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
-  let balTo = balanceLinked fv precision
+  let balTo = balanceLinked fv
   ts' <- doEntries balTo k tot t0 ts
   return $
     InsertEntrySet
@@ -923,9 +924,9 @@ balanceFinal k@(curID, _) tot precision fs t0 ts = do
 
 doEntries
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
-  -> Rational
+  -> Decimal
   -> Entry (AccountRId, AcntSign) () TagRId
   -> [Entry (AccountRId, AcntSign) v TagRId]
   -> StateT EntryBals m (NonEmpty InsertEntry)
@@ -949,39 +950,34 @@ liftInnerS = mapStateT (return . runIdentity)
 
 balanceLinked
   :: MonadInsertError m
-  => Vector Rational
-  -> Natural
+  => Vector Decimal
   -> ABCKey
-  -> LinkDeferred Rational
-  -> StateT EntryBals m (Rational, Maybe DBDeferred)
-balanceLinked from precision k lg = case lg of
+  -> LinkDeferred
+  -> StateT EntryBals m (Decimal, Maybe DBDeferred)
+balanceLinked from k 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)
+      Just v -> return (v, Just $ DBEntryLinked lngIndex 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 precision k d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred k d
   where
-    go s = negate . roundPrecision precision . (* s) . fromRational
+    go s = negate . (*. s)
 
-balanceDeferred
-  :: Natural
-  -> ABCKey
-  -> EntryValue Rational
-  -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred prec k (EntryValue t v) = do
-  newval <- findBalance prec k t v
-  let d = case t of
-        TFixed -> Nothing
-        TBalance -> Just $ EntryBalance v
-        TPercent -> Just $ EntryPercent v
+balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
+balanceDeferred k e = do
+  newval <- findBalance k e
+  let d = case e of
+        EntryFixed _ -> Nothing
+        EntryBalance v -> Just $ DBEntryBalance v
+        EntryPercent v -> Just $ DBEntryPercent v
   return (newval, d)
 
 balanceEntry
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
   -> Entry (AccountRId, AcntSign) v TagRId
   -> StateT EntryBals m InsertEntry
@@ -1005,18 +1001,13 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
   combineError acntRes tagRes $
     \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
 
-findBalance
-  :: Natural
-  -> ABCKey
-  -> TransferType
-  -> Rational
-  -> State EntryBals Rational
-findBalance prec k t v = do
+findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
+findBalance k e = do
   curBal <- gets (M.findWithDefault 0 k)
-  return $ roundPrecision prec $ fromRational $ case t of
-    TBalance -> v - curBal
-    TPercent -> v * curBal
-    TFixed -> v
+  return $ case e of
+    EntryBalance b -> b - curBal
+    EntryPercent p -> curBal *. p
+    EntryFixed v -> v
 
 --------------------------------------------------------------------------------
 -- transfers
@@ -1047,14 +1038,20 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
         , amtPriority = pri
-        } =
-        withDates bounds pat $ \day -> do
-          p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
+        } = do
+        cp <- lookupCurrency transCurrency
+        let v' = (-v)
+        let dec = realFracToDecimal (cpPrec cp) v'
+        let v'' = case t of
+              TFixed -> EntryFixed dec
+              TPercent -> EntryPercent v'
+              TBalance -> EntryBalance dec
+        withDates bounds pat $ \day ->
           return
             Tx
               { txCommit = tc
               , txDate = day
-              , txPrimary = Right p
+              , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
               , txOther = []
               , txDescr = desc
               , txBudget = name
@@ -1062,23 +1059,20 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
               }
 
 entryPair
-  :: (MonadInsertError m, MonadFinance m)
-  => TaggedAcnt
+  :: TaggedAcnt
   -> TaggedAcnt
-  -> CurID
+  -> CurrencyRId
   -> T.Text
   -> v0
   -> v1
-  -> m (EntrySet v0 v1 v2 v3)
-entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
-  cp <- lookupCurrency curid
-  return $
-    EntrySet
-      { esCurrency = cp
-      , esTotalValue = totval
-      , esFrom = halfEntry fa fts val1
-      , esTo = halfEntry ta tts ()
-      }
+  -> EntrySet v0 v1 v2 v3
+entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
+  EntrySet
+    { esCurrency = curid
+    , esTotalValue = totval
+    , esFrom = halfEntry fa fts val1
+    , esTo = halfEntry ta tts ()
+    }
   where
     halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
     halfEntry a ts v =
diff --git a/package.yaml b/package.yaml
index 93b2fc3..2801a9a 100644
--- a/package.yaml
+++ b/package.yaml
@@ -87,6 +87,7 @@ dependencies:
 - filepath
 - mtl
 - persistent-mtl >= 0.3.0.0
+- Decimal >= 0.5.2
 
 library:
   source-dirs: lib/

From bf1434542fcf411f7bf54115e2d779989f7d6cf1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 8 Jul 2023 19:05:34 -0400
Subject: [PATCH 46/59] ENH remove useless field

---
 dhall/Types.dhall           | 7 +------
 lib/Internal/Types/Dhall.hs | 3 ---
 2 files changed, 1 insertion(+), 9 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 606e5d4..f0b1190 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -778,12 +778,7 @@ let Allocation =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { alloTo : TaggedAcnt.Type
-        , alloAmts : List (Amount w v).Type
-        , alloCur :
-            {-TODO allow exchanges here-}
-            CurID
-        }
+        { alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }
 
 let PretaxValue =
     {-
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index b2ca0c6..6a060a2 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -262,8 +262,6 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
 
 deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
 
--- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
-
 deriving instance (Show w, Show v) => Show (Amount w v)
 
 deriving instance (Eq w, Eq v) => Eq (Amount w v)
@@ -271,7 +269,6 @@ deriving instance (Eq w, Eq v) => Eq (Amount w v)
 data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
   , alloAmts :: [Amount w v]
-  , alloCur :: CurID
   }
   deriving (Eq, Show, Generic, Hashable)
 

From 9c93ad25af3e43ad5598a0f0d723b068c47d31a1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 9 Jul 2023 00:16:57 -0400
Subject: [PATCH 47/59] ENH break up input files to thread them

---
 app/Main.hs                 | 84 ++++++++++++++++++++++++++++++++-----
 lib/Internal/Database.hs    | 32 +++++++-------
 lib/Internal/Types/Dhall.hs |  4 +-
 lib/Internal/Utils.hs       |  9 ++++
 4 files changed, 99 insertions(+), 30 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 60c403e..87eb835 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -2,13 +2,15 @@
 
 module Main (main) where
 
+import Control.Concurrent
 import Control.Monad.Except
 import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Control.Monad.Reader
+import Data.Bitraversable
 import qualified Data.Text.IO as TI
 import Database.Persist.Monad
-import Dhall hiding (double, record)
+import qualified Dhall hiding (double, record)
 import Internal.Budget
 import Internal.Database
 import Internal.History
@@ -30,14 +32,26 @@ main = parse =<< execParser o
             <> header "pwncash - your budget, your life"
         )
 
-data Options = Options FilePath Mode
+type ConfigPath = FilePath
+
+type BudgetPath = FilePath
+
+type HistoryPath = FilePath
+
+data Options = Options !ConfigPath !Mode
 
 data Mode
   = Reset
   | DumpCurrencies
   | DumpAccounts
   | DumpAccountKeys
-  | Sync
+  | Sync !SyncOptions
+
+data SyncOptions = SyncOptions
+  { syncBudgets :: ![BudgetPath]
+  , syncHistories :: ![HistoryPath]
+  , syncThreads :: !Int
+  }
 
 configFile :: Parser FilePath
 configFile =
@@ -104,6 +118,35 @@ sync =
         <> short 'S'
         <> help "Sync config to database"
     )
+    <*> syncOptions
+
+syncOptions :: Parser SyncOptions
+syncOptions =
+  SyncOptions
+    <$> many
+      ( strOption
+          ( long "budget"
+              <> short 'b'
+              <> metavar "BUDGET"
+              <> help "path to a budget config"
+          )
+      )
+    <*> many
+      ( strOption
+          ( long "history"
+              <> short 'H'
+              <> metavar "HISTORY"
+              <> help "path to a history config"
+          )
+      )
+    <*> option
+      auto
+      ( long "threads"
+          <> short 't'
+          <> metavar "THREADS"
+          <> value 1
+          <> help "number of threads for syncing"
+      )
 
 parse :: Options -> IO ()
 parse (Options c Reset) = do
@@ -112,7 +155,8 @@ parse (Options c Reset) = do
 parse (Options c DumpAccounts) = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies) = runDumpCurrencies c
-parse (Options c Sync) = runSync c
+parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
+  runSync syncThreads c syncBudgets syncHistories
 
 runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
 runDumpCurrencies c = do
@@ -160,29 +204,42 @@ runDumpAccountKeys c = do
     t3 (_, _, x) = x
     double x = (x, x)
 
-runSync :: FilePath -> IO ()
-runSync c = do
+runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
+runSync threads c bs hs = do
+  setNumCapabilities threads
+  -- putStrLn "reading config"
   config <- readConfig c
+  -- putStrLn "reading statements"
+  (bs', hs') <-
+    fmap (bimap concat concat . partitionEithers) $
+      pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
+        (Left <$> bs) ++ (Right <$> hs)
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
+  putStrLn "doing other stuff"
+  setNumCapabilities 1
   handle err $ do
     -- _ <- askLoggerIO
 
     -- Get the current DB state.
     (state, updates) <- runSqlQueryT pool $ do
       runMigration migrateAll
-      liftIOExceptT $ getDBState config
+      liftIOExceptT $ getDBState config bs' hs'
 
     -- 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
+        let (hTs, hSs) = splitHistory hs'
+        -- TODO for some mysterious reason using multithreading just for this
+        -- little bit slows the program down by several seconds
+        -- lift $ setNumCapabilities threads
         hSs' <- mapErrorsIO (readHistStmt root) hSs
+        -- lift $ setNumCapabilities 1
         -- lift $ print $ length $ lefts hSs'
         -- lift $ print $ length $ rights hSs'
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         -- lift $ print $ length $ lefts hTs'
-        bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
+        bTs <- liftIOExceptT $ mapErrors readBudget bs'
         -- lift $ print $ length $ lefts bTs
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
     -- print $ length $ kmNewCommits state
@@ -218,4 +275,11 @@ runSync c = do
 -- showBalances
 
 readConfig :: MonadUnliftIO m => FilePath -> m Config
-readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath
+readConfig = fmap unfix . readDhall
+
+readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
+readDhall confpath = do
+  -- tid <- myThreadId
+  -- liftIO $ print $ show tid
+  -- liftIO $ print confpath
+  liftIO $ Dhall.inputFile Dhall.auto confpath
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 0209355..2ede03c 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -109,16 +109,12 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
-hashConfig :: Config -> [Int]
-hashConfig
-  Config_
-    { budget = bs
-    , statements = ss
-    } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
-    where
-      (ms, ps) = partitionEithers $ fmap go ss
-      go (HistTransfer x) = Left x
-      go (HistStatement x) = Right x
+hashConfig :: [Budget] -> [History] -> [Int]
+hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
+  where
+    (ms, ps) = partitionEithers $ fmap go hs
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
 
 setDiff :: Eq a => [a] -> [a] -> ([a], [a])
 -- setDiff = setDiff' (==)
@@ -148,9 +144,9 @@ nukeDBHash h = deleteE $ do
 nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
-getConfigHashes c = do
-  let ch = hashConfig c
+getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
+getConfigHashes bs hs = do
+  let ch = hashConfig bs hs
   dh <- getDBHashes
   return $ setDiff dh ch
 
@@ -306,9 +302,11 @@ indexAcntRoot r =
 getDBState
   :: (MonadInsertError m, MonadSqlQuery m)
   => Config
+  -> [Budget]
+  -> [History]
   -> m (DBState, DBUpdates)
-getDBState c = do
-  (del, new) <- getConfigHashes c
+getDBState c bs hs = do
+  (del, new) <- getConfigHashes bs hs
   combineError bi si $ \b s ->
     ( DBState
         { kmCurrency = currencyMap cs
@@ -327,8 +325,8 @@ getDBState c = do
         }
     )
   where
-    bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
-    si = liftExcept $ resolveDaySpan $ statementInterval $ global c
+    bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
+    si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
     (acnts, paths, am) = indexAcntRoot $ accounts c
     cs = currency2Record <$> currencies c
     ts = toRecord <$> tags c
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 6a060a2..5cb6af0 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -380,10 +380,8 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 data Config_ a = Config_
-  { global :: !TemporalScope
-  , budget :: ![Budget]
+  { scope :: !TemporalScope
   , currencies :: ![Currency]
-  , statements :: ![History]
   , accounts :: !a
   , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index bf6168f..32cd18f 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -27,6 +27,7 @@ module Internal.Utils
   , combineErrorIOM3
   , collectErrorsIO
   , mapErrorsIO
+  , mapErrorsPooledIO
   , showError
   , acntPath2Text
   , showT
@@ -387,6 +388,14 @@ combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d)
 combineErrorIOM3 a b c f =
   combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
 
+mapErrorsPooledIO :: (Traversable t, MonadUnliftIO m) => Int -> (a -> m b) -> t a -> m (t b)
+mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs
+  where
+    go (n, x) = catch (f x) $ \(InsertException e) -> do
+      es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
+      throwIO $ InsertException $ foldr (<>) e es
+    err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
+
 mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
 mapErrorsIO f xs = mapM go $ enumTraversable xs
   where

From c8f7689c7a40e251b2e1a9d2bea3931a1af43cf1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 9 Jul 2023 11:13:35 -0400
Subject: [PATCH 48/59] ENH store account sign in db itself

---
 lib/Internal/Database.hs       |  8 +--
 lib/Internal/Types/Database.hs | 19 ++++++-
 lib/Internal/Types/Main.hs     |  5 +-
 lib/Internal/Utils.hs          | 98 +++++++++++++---------------------
 4 files changed, 60 insertions(+), 70 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 2ede03c..62ed6eb 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -201,7 +201,7 @@ toKey = toSqlKey . fromIntegral . hash
 tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
 tree2Entity t parents name des =
   Entity (toSqlKey $ fromIntegral h) $
-    AccountR name (toPath parents) des
+    AccountR name (toPath parents) des (accountSign t)
   where
     p = AcntPath t (reverse (name : parents))
     h = hash p
@@ -210,7 +210,7 @@ tree2Entity t parents name des =
 tree2Records
   :: AcntType
   -> AccountTree
-  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
+  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
@@ -225,10 +225,10 @@ tree2Records t = go []
           k = entityKey e
        in ( [acnt k n (fmap snd ps) d]
           , expand k $ fmap fst ps
-          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
+          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))]
           )
     toPath = T.intercalate "/" . (atName t :) . reverse
-    acnt k n ps = Entity k . AccountR n (toPath ps)
+    acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign
     expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
     sign = accountSign t
 
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index b3f4564..1d4be04 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -34,6 +34,7 @@ AccountR sql=accounts
     name T.Text
     fullpath T.Text
     desc T.Text
+    sign AcntSign
     deriving Show Eq
 AccountPathR sql=account_paths
     parent AccountRId OnDeleteCascade
@@ -78,7 +79,21 @@ instance PersistFieldSql ConfigType where
 instance PersistField ConfigType where
   toPersistValue = PersistText . T.pack . show
 
-  -- TODO these error messages *might* be good enough?
   fromPersistValue (PersistText v) =
     maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
-  fromPersistValue _ = Left "wrong type"
+  fromPersistValue _ = Left "not a string"
+
+data AcntSign = Credit | Debit
+  deriving (Show, Eq, Ord)
+
+instance PersistFieldSql AcntSign where
+  sqlType _ = SqlInt64
+
+instance PersistField AcntSign where
+  toPersistValue Debit = PersistInt64 1
+  toPersistValue Credit = PersistInt64 (-1)
+
+  fromPersistValue (PersistInt64 1) = Right Debit
+  fromPersistValue (PersistInt64 (-1)) = Right Credit
+  fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
+  fromPersistValue _ = Left "not an Int64"
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 7ac50db..2e36bc2 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -35,7 +35,7 @@ data ConfigHashes = ConfigHashes
   , chImport :: ![Int]
   }
 
-type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
+type AccountMap = M.Map AcntID (AccountRId, AcntType)
 
 data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
   deriving (Show)
@@ -186,9 +186,6 @@ data Keyed a = Keyed
 
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
-data AcntSign = Credit | Debit
-  deriving (Show)
-
 -- TODO debit should be negative
 sign2Int :: AcntSign -> Int
 sign2Int Debit = 1
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 32cd18f..e5758be 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -30,19 +30,15 @@ module Internal.Utils
   , mapErrorsPooledIO
   , showError
   , acntPath2Text
-  , showT
+  , tshow
   , lookupErr
   , gregorians
   , uncurry3
-  , fstOf3
-  , sndOf3
-  , thdOf3
   , xGregToDay
   , dateMatches
   , valMatches
   , lookupAccount
   , lookupAccountKey
-  , lookupAccountSign
   , lookupAccountType
   , lookupCurrency
   , lookupCurrencyKey
@@ -410,7 +406,7 @@ collectErrorsIO = mapErrorsIO id
 lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
 lookupErr what k m = case M.lookup k m of
   Just x -> return x
-  _ -> throwError $ InsertException [LookupError what $ showT k]
+  _ -> throwError $ InsertException [LookupError what $ tshow k]
 
 fmtRational :: Natural -> Rational -> T.Text
 fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
@@ -439,7 +435,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 
 showError :: InsertError -> [T.Text]
 showError other = case other of
-  (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
+  (StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms)
   (DaySpanError a b) ->
     [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
     where
@@ -461,9 +457,9 @@ showError other = case other of
         keyVals $
           [ (k, v)
           | (k, Just v) <-
-              [ ("start", Just $ showT s)
-              , ("by", Just $ showT b)
-              , ("repeats", showT <$> r)
+              [ ("start", Just $ tshow s)
+              , ("by", Just $ tshow b)
+              , ("repeats", tshow <$> r)
               ]
           ]
       msg = case p of
@@ -474,7 +470,7 @@ showError other = case other of
   (InsertIOError msg) -> [T.append "IO Error: " msg]
   (ParseError msg) -> [T.append "Parse Error: " msg]
   (MatchValPrecisionError d p) ->
-    [T.unwords ["Match denominator", showT d, "must be less than", showT p]]
+    [T.unwords ["Match denominator", tshow d, "must be less than", tshow p]]
   (LookupError t f) ->
     [T.unwords ["Could not find field", f, "when resolving", what]]
     where
@@ -494,27 +490,27 @@ showError other = case other of
         [ "Income allocations for budget"
         , singleQuote name
         , "exceed total on day"
-        , showT day
+        , tshow day
         , "where balance is"
-        , showT (fromRational balance :: Double)
+        , tshow (fromRational balance :: Double)
         ]
     ]
   (PeriodError start next) ->
     [ T.unwords
         [ "First pay period on "
-        , singleQuote $ showT start
+        , singleQuote $ tshow start
         , "must start before first income payment on "
-        , singleQuote $ showT next
+        , singleQuote $ tshow next
         ]
     ]
   (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
     [ T.unwords
         [ "No credit entry for index"
-        , singleQuote $ showT lngIndex
+        , singleQuote $ tshow lngIndex
         , "for entry with account"
         , singleQuote eAcnt
         , "on"
-        , showT day
+        , tshow day
         ]
     ]
   (RoundError cur) ->
@@ -525,15 +521,15 @@ showError other = case other of
     ]
 
 showGregorian_ :: Gregorian -> T.Text
-showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
+showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
 
-showTx :: TxRecord -> T.Text
-showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
+tshowx :: TxRecord -> T.Text
+tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
   T.append "Unmatched transaction: " $
     keyVals
       [ ("path", T.pack f)
       , ("date", T.pack $ iso8601Show d)
-      , ("value", showT v)
+      , ("value", tshow v)
       , ("description", doubleQuote e)
       ]
 
@@ -546,8 +542,8 @@ showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority}
       , ("val", showValMatcher spVal)
       , ("desc", fst <$> spDesc)
       , ("other", others)
-      , ("counter", Just $ maybe "Inf" showT spTimes)
-      , ("priority", Just $ showT spPriority)
+      , ("counter", Just $ maybe "Inf" tshow spTimes)
+      , ("priority", Just $ tshow spPriority)
       ]
     others = case spOther of
       [] -> Nothing
@@ -580,7 +576,7 @@ showYMDMatcher = showYMD_ . fromYMDMatcher
 
 showYMD_ :: YMD_ -> T.Text
 showYMD_ md =
-  T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
+  T.intercalate "-" $ L.take 3 (fmap tshow digits ++ L.repeat "*")
   where
     digits = case md of
       Y_ y -> [fromIntegral y]
@@ -594,9 +590,9 @@ showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
   where
     kvs =
       [ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
-      , ("numerator", showT <$> vmNum)
-      , ("denominator", showT <$> vmDen)
-      , ("precision", Just $ showT vmPrec)
+      , ("numerator", tshow <$> vmNum)
+      , ("denominator", tshow <$> vmDen)
+      , ("precision", Just $ tshow vmPrec)
       ]
 
 showMatchOther :: FieldMatcherRe -> T.Text
@@ -622,9 +618,6 @@ keyVal a b = T.concat [a, "=", b]
 keyVals :: [(T.Text, T.Text)] -> T.Text
 keyVals = T.intercalate "; " . fmap (uncurry keyVal)
 
-showT :: Show a => a -> T.Text
-showT = T.pack . show
-
 --------------------------------------------------------------------------------
 -- random functions
 
@@ -644,26 +637,14 @@ mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
-fstOf3 :: (a, b, c) -> a
-fstOf3 (a, _, _) = a
-
-sndOf3 :: (a, b, c) -> b
-sndOf3 (_, b, _) = b
-
-thdOf3 :: (a, b, c) -> c
-thdOf3 (_, _, c) = c
-
-lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
+lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
 lookupAccount = lookupFinance AcntField kmAccount
 
 lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
-lookupAccountKey = fmap fstOf3 . lookupAccount
-
-lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
-lookupAccountSign = fmap sndOf3 . lookupAccount
+lookupAccountKey = fmap fst . lookupAccount
 
 lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
-lookupAccountType = fmap thdOf3 . lookupAccount
+lookupAccountType = fmap snd . lookupAccount
 
 lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
 lookupCurrency = lookupFinance CurField kmCurrency
@@ -917,8 +898,8 @@ balanceFinal
   => BCKey
   -> Decimal
   -> NonEmpty InsertEntry
-  -> Entry (AccountRId, AcntSign) () TagRId
-  -> [Entry (AccountRId, AcntSign) LinkDeferred TagRId]
+  -> Entry AccountRId () TagRId
+  -> [Entry AccountRId LinkDeferred TagRId]
   -> StateT EntryBals m InsertEntrySet
 balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
@@ -936,18 +917,17 @@ doEntries
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
   -> Decimal
-  -> Entry (AccountRId, AcntSign) () TagRId
-  -> [Entry (AccountRId, AcntSign) v TagRId]
+  -> Entry AccountRId () TagRId
+  -> [Entry AccountRId v TagRId]
   -> StateT EntryBals m (NonEmpty InsertEntry)
-doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
+doEntries f k tot e@Entry {eAcnt = acntID} 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, k) e0val)
   let e' =
         InsertEntry
-          { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
+          { ieEntry = e {eValue = e0val, eAcnt = acntID}
           , ieDeferred = Nothing
           }
   return $ e' :| es'
@@ -988,27 +968,25 @@ balanceEntry
   :: (MonadInsertError m)
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
-  -> Entry (AccountRId, AcntSign) v TagRId
+  -> Entry AccountRId v TagRId
   -> StateT EntryBals m InsertEntry
-balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
-  let s = fromIntegral $ sign2Int sign
+balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
   (newVal, deferred) <- f (acntID, k) eValue
   modify (mapAdd_ (acntID, k) newVal)
   return $
     InsertEntry
-      { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
+      { ieEntry = e {eValue = newVal, eAcnt = acntID}
       , ieDeferred = deferred
       }
 
 resolveAcntAndTags
   :: (MonadInsertError m, MonadFinance m)
   => Entry AcntID v TagID
-  -> m (Entry (AccountRId, AcntSign) v TagRId)
+  -> m (Entry AccountRId v TagRId)
 resolveAcntAndTags e@Entry {eAcnt, eTags} = do
-  let acntRes = lookupAccount eAcnt
+  let acntRes = lookupAccountKey eAcnt
   let tagRes = mapErrors lookupTag eTags
-  combineError acntRes tagRes $
-    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
+  combineError acntRes tagRes $ \a ts -> e {eAcnt = a, eTags = ts}
 
 findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
 findBalance k e = do

From 4c46f035f5dd0a2de164840b041b3fb3ba9e90ea Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 13 Jul 2023 23:31:27 -0400
Subject: [PATCH 49/59] WIP use more robust update strategy

---
 app/Main.hs                    |  35 +-
 lib/Internal/Budget.hs         |  47 +--
 lib/Internal/Database.hs       | 562 ++++++++++++++++++++++++---------
 lib/Internal/History.hs        |  24 +-
 lib/Internal/Types/Database.hs |  48 ++-
 lib/Internal/Types/Dhall.hs    |   2 +-
 lib/Internal/Types/Main.hs     |  87 ++---
 lib/Internal/Utils.hs          |  26 +-
 8 files changed, 557 insertions(+), 274 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 87eb835..dc5d97f 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -9,6 +9,7 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Data.Bitraversable
 import qualified Data.Text.IO as TI
+import qualified Database.Esqueleto.Experimental as E
 import Database.Persist.Monad
 import qualified Dhall hiding (double, record)
 import Internal.Budget
@@ -194,14 +195,13 @@ runDumpAccountKeys c = do
   ar <- accounts <$> readConfig c
   let ks =
         paths2IDs $
-          fmap (double . fst) $
-            concatMap (t3 . uncurry tree2Records) $
-              flattenAcntRoot ar
+          fmap (double . accountRFullpath . E.entityVal) $
+            fst $
+              indexAcntRoot ar
   mapM_ (uncurry printPair) ks
   where
     printPair i p = do
       liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
-    t3 (_, _, x) = x
     double x = (x, x)
 
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
@@ -221,27 +221,29 @@ runSync threads c bs hs = do
     -- _ <- askLoggerIO
 
     -- Get the current DB state.
-    (state, updates) <- runSqlQueryT pool $ do
+    state <- runSqlQueryT pool $ do
       runMigration migrateAll
-      liftIOExceptT $ getDBState config bs' hs'
+      liftIOExceptT $ readConfigState config bs' hs'
 
     -- 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) <-
+    toIns <-
       flip runReaderT state $ do
-        let (hTs, hSs) = splitHistory hs'
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
+        (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         -- lift $ setNumCapabilities 1
         -- lift $ print $ length $ lefts hSs'
         -- lift $ print $ length $ rights hSs'
+        (CRUDOps hTs _ _ _) <- askDBState csHistTrans
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         -- lift $ print $ length $ lefts hTs'
-        bTs <- liftIOExceptT $ mapErrors readBudget bs'
+        (CRUDOps bTs _ _ _) <- askDBState csBudgets
+        bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         -- lift $ print $ length $ lefts bTs
-        return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
+        return $ concat $ hSs' ++ hTs' ++ bTs'
     -- print $ length $ kmNewCommits state
     -- print $ length $ duOldCommits updates
     -- print $ length $ duNewTagIds updates
@@ -252,15 +254,12 @@ runSync threads c bs hs = do
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       -- NOTE this must come first (unless we defer foreign keys)
-      updateDBState updates
-      -- TODO skip this entire section if the database won't change (eg length
-      -- of 'is' is zero and there are no commits to delete)
+      updateDBState
       res <- runExceptT $ do
-        -- TODO taking out the hash is dumb
-        (rs, ues) <- readUpdates $ fmap commitRHash rus
-        -- rerunnableIO $ print ues
-        -- rerunnableIO $ print $ length rs
-        let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
+        (CRUDOps _ bRs bUs _) <- askDBState csBudgets
+        (CRUDOps _ tRs tUs _) <- askDBState csHistTrans
+        (CRUDOps _ sRs sUs _) <- askDBState csHistStmts
+        let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
         insertAll ebs
       -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
       -- whatever error is encountered above in an IO context, but the first
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index ad685f9..251701e 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -3,7 +3,7 @@ module Internal.Budget (readBudget) where
 import Control.Monad.Except
 import Data.Decimal hiding (allocate)
 import Data.Foldable
-import Internal.Database
+import Data.Hashable
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -13,10 +13,7 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
-readBudget
-  :: (MonadInsertError m, MonadFinance m)
-  => Budget
-  -> m (Either CommitR [Tx CommitR])
+readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR]
 readBudget
   b@Budget
     { bgtLabel
@@ -28,18 +25,19 @@ readBudget
     , bgtPosttax
     , bgtInterval
     } =
-    eitherHash CTBudget b return $ \key -> do
+    do
       spanRes <- getSpan
       case spanRes of
         Nothing -> return []
         Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
+          let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
     where
+      c = CommitR (hash b) CTBudget
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
       pre_ = sortAllos bgtPretax
@@ -51,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState kmBudgetInterval
+        globalSpan <- askDBState csBudgetScope
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -124,7 +122,7 @@ readIncome
       flatTax = concatMap flattenAllo incTaxes
       flatPost = concatMap flattenAllo incPosttax
       sumAllos = sum . fmap faValue
-      -- TODO ensure these are all the "correct" accounts
+      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
       allocate cp gross prevDay day = do
         scaler <- liftExcept $ periodScaler pType' prevDay day
         let precision = cpPrec cp
@@ -138,21 +136,8 @@ readIncome
         let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-        -- TODO double or rational here?
-        let src =
-              Entry
-                { eAcnt = srcAcnt
-                , eValue = ()
-                , eComment = ""
-                , eTags = srcTags
-                }
-        let dest =
-              Entry
-                { eAcnt = destAcnt
-                , eValue = ()
-                , eComment = "balance after deductions"
-                , eTags = destTags
-                }
+        let src = entry0 srcAcnt "gross income" srcTags
+        let dest = entry0 destAcnt "balance after deductions" destTags
         let allos = allo2Trans <$> (pre ++ tax ++ post)
         let primary =
               EntrySet
@@ -357,11 +342,13 @@ fromShadow
   => Tx CommitR
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
-fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
-  cp <- lookupCurrency stCurrency
-  res <- liftExcept $ shadowMatches stMatch tx
-  let es = entryPair stFrom stTo (cpID cp) stDesc stRatio ()
-  return $ if not res then Nothing else Just es
+fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
+  combineErrorM curRes shaRes $ \cur sha -> do
+    let es = entryPair stFrom stTo cur stDesc stRatio ()
+    return $ if not sha then Nothing else Just es
+  where
+    curRes = lookupCurrencyKey stCurrency
+    shaRes = liftExcept $ shadowMatches stMatch tx
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 62ed6eb..83fe253 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -1,17 +1,15 @@
 module Internal.Database
   ( runDB
+  , readConfigState
   , nukeTables
   , updateHashes
   , updateDBState
   , getDBState
   , tree2Records
   , flattenAcntRoot
+  , indexAcntRoot
   , paths2IDs
   , mkPool
-  , whenHash0
-  , whenHash
-  , whenHash_
-  , eitherHash
   , insertEntry
   , readUpdates
   , insertAll
@@ -29,7 +27,8 @@ import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
 import Database.Persist.Sqlite hiding
-  ( delete
+  ( Statement
+  , delete
   , deleteWhere
   , insert
   , insertKey
@@ -43,10 +42,11 @@ import GHC.Err
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
-import RIO.List ((\\))
+import qualified RIO.HashSet as HS
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
+-- import qualified RIO.Set as S
 import qualified RIO.Text as T
 
 runDB
@@ -109,6 +109,186 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
+-- data TxState = TxState
+--   { tsBudget :: !(CRUDOps () () () ())
+--   , tsHistTransfer :: !(CRUDOps () () () ())
+--   , tsHistStatement :: !(CRUDOps () () () ())
+--   }
+
+-- readTxState :: (MonadFinance m, MonadUnliftIO m) -> [Budget] -> [History] -> m TxState
+-- readTxState bs hs = do
+--   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
+
+readConfigState
+  :: (MonadInsertError m, MonadSqlQuery m)
+  => Config
+  -> [Budget]
+  -> [History]
+  -> m ConfigState
+readConfigState c bs hs = do
+  curAcnts <- readCurrentIds AccountRId
+  curTags <- readCurrentIds TagRId
+  curCurs <- readCurrentIds CurrencyRId
+  curPaths <- readCurrentIds AccountPathRId
+  let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts
+  let (pathsIns, _, pathsDel) = diff newPaths curPaths
+  let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs
+  let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags
+  let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
+  let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
+  let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
+  let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
+  let existing =
+        ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
+
+  (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
+  (bChanged, hChanged) <- readScopeChanged $ scope c
+  bgt <- makeTxCRUD existing bs curBgts bChanged
+  hTrans <- makeTxCRUD existing ts curHistTrs hChanged
+  hStmt <- makeTxCRUD existing ss curHistSts hChanged
+
+  let bsRes = resolveScope budgetInterval
+  let hsRes = resolveScope statementInterval
+  combineError bsRes hsRes $ \b h ->
+    ConfigState
+      { csCurrencies = CRUDOps curs2Ins () () curs2Del
+      , csTags = CRUDOps tags2Ins () () tags2Del
+      , csAccounts = CRUDOps acnts2Ins () () acnts2Del
+      , csPaths = CRUDOps pathsIns () () pathsDel
+      , csBudgets = bgt
+      , csHistTrans = hTrans
+      , csHistStmts = hStmt
+      , csAccountMap = amap
+      , csCurrencyMap = cmap
+      , csTagMap = tmap
+      , csBudgetScope = b
+      , csHistoryScope = h
+      }
+  where
+    (ts, ss) = splitHistory hs
+    diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a])
+    diff = setDiffWith (\a b -> E.entityKey a == b)
+    (newAcnts, newPaths) = indexAcntRoot $ accounts c
+    newTags = tag2Record <$> tags c
+    newCurs = currency2Record <$> currencies c
+    resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
+
+readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool)
+readScopeChanged s = do
+  rs <- dumpTbl
+  case rs of
+    [] -> return (True, True)
+    [r] -> do
+      let (ConfigStateR hsh bsh) = E.entityVal r
+      return
+        ( hashScope budgetInterval == bsh
+        , hashScope statementInterval == hsh
+        )
+    _ -> throwError undefined
+  where
+    hashScope f = hash $ f s
+
+makeTxCRUD
+  :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
+  => ExistingConfig
+  -> [a]
+  -> [Int]
+  -> Bool
+  -> m
+      ( CRUDOps
+          [a]
+          [ReadEntry]
+          [Either TotalUpdateEntrySet FullUpdateEntrySet]
+          DeleteTxs
+      )
+makeTxCRUD existing newThings curThings scopeChanged = do
+  let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings
+  -- Check the overlap for rows with accounts/tags/currencies that
+  -- won't exist on the next update. Those with invalid IDs will be set aside
+  -- to delete and reinsert (which may also fail) later
+  (toInsRetry, noRetry) <- readInvalidIds existing overlap
+  let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
+  let toInsAll = (snd <$> toInsRetry) ++ toIns
+  -- If we are inserting or deleting something or the scope changed, pull out
+  -- the remainder of the entries to update/read as we are (re)inserting other
+  -- stuff (this is necessary because a given transaction may depend on the
+  -- value of previous transactions, even if they are already in the DB).
+  (toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
+    ([], [], False) -> return ([], [])
+    _ -> readUpdates noRetry
+  toDelAll <- readTxIds toDelAllHashes
+  return $ CRUDOps toInsAll toRead toUpdate toDelAll
+  where
+    go a b = hash b == a
+
+readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
+readTxIds cs = do
+  xs <- selectE $ do
+    (commits :& txs :& ess :& es :& ts) <-
+      E.from
+        $ E.table
+          `E.innerJoin` E.table
+        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
+    E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
+    return
+      ( txs ^. TransactionRId
+      , ess ^. EntrySetRId
+      , es ^. EntryRId
+      , ts ^. TagRelationRId
+      )
+  let (txs, ss, es, ts) = L.unzip4 xs
+  return $
+    DeleteTxs
+      { dtTxs = go txs
+      , dtEntrySets = go ss
+      , dtEntries = go es
+      , dtTagRelations = E.unValue <$> ts
+      }
+  where
+    go :: Eq a => [E.Value a] -> [a]
+    go = fmap (E.unValue . NE.head) . NE.group
+
+splitHistory :: [History] -> ([PairedTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
+makeTagMap :: [Entity TagR] -> TagMap
+makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+
+tag2Record :: Tag -> Entity TagR
+tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+
+currency2Record :: Currency -> Entity CurrencyR
+currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
+  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
+
+readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a]
+readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do
+  rs <- E.from E.table
+  return (rs ^. f)
+
+readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
+readCurrentCommits = do
+  xs <- selectE $ do
+    rs <- E.from E.table
+    return (rs ^. CommitRHash, rs ^. CommitRType)
+  return $ foldr go ([], [], []) xs
+  where
+    go (x, t) (bs, ts, hs) =
+      let y = E.unValue x
+       in case E.unValue t of
+            CTBudget -> (y : bs, ts, hs)
+            CTTransfer -> (bs, y : ts, hs)
+            CTHistory -> (bs, ts, y : hs)
+
 hashConfig :: [Budget] -> [History] -> [Int]
 hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
   where
@@ -116,22 +296,28 @@ hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-setDiff :: Eq a => [a] -> [a] -> ([a], [a])
--- setDiff = setDiff' (==)
-setDiff as bs = (as \\ bs, bs \\ as)
+setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
+setDiff2 = setDiffWith2 (==)
 
--- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
--- setDiff' f = go []
---   where
---     go inA [] bs     = (inA, bs)
---     go inA as []     = (as ++ inA, [])
---     go inA (a:as) bs = case inB a bs of
---       Just bs' -> go inA as bs'
---       Nothing  -> go (a:inA) as bs
---     inB _ [] = Nothing
---     inB a (b:bs)
---       | f a b = Just bs
---       | otherwise = inB a bs
+-- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
+-- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
+
+-- setDiff as bs = (as \\ bs, bs \\ as)
+setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
+setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
+
+setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
+setDiffWith f = go [] []
+  where
+    go inA inBoth [] bs = (inA, inBoth, bs)
+    go inA inBoth as [] = (as ++ inA, inBoth, [])
+    go inA inBoth (a : as) bs = case inB a bs of
+      Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
+      Nothing -> go (a : inA) inBoth as bs
+    inB _ [] = Nothing
+    inB a (b : bs)
+      | f a b = Just (b, bs)
+      | otherwise = inB a bs
 
 getDBHashes :: MonadSqlQuery m => m [Int]
 getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@@ -148,42 +334,38 @@ getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
 getConfigHashes bs hs = do
   let ch = hashConfig bs hs
   dh <- getDBHashes
-  return $ setDiff dh ch
+  return $ setDiff2 dh ch
 
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
 
-deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
-deleteAccount e = deleteE $ do
-  c <- E.from $ E.table @AccountR
-  E.where_ (c ^. AccountRId ==. E.val k)
-  where
-    k = entityKey e
+-- deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
+-- deleteAccount e = deleteE $ do
+--   c <- E.from $ E.table @AccountR
+--   E.where_ (c ^. AccountRId ==. E.val k)
+--   where
+--     k = entityKey e
 
-deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
-deleteCurrency e = deleteE $ do
-  c <- E.from $ E.table @CurrencyR
-  E.where_ (c ^. CurrencyRId ==. E.val k)
-  where
-    k = entityKey e
+-- deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
+-- deleteCurrency e = deleteE $ do
+--   c <- E.from $ E.table @CurrencyR
+--   E.where_ (c ^. CurrencyRId ==. E.val k)
+--   where
+--     k = entityKey e
 
-deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
-deleteTag e = deleteE $ do
-  c <- E.from $ E.table @TagR
-  E.where_ (c ^. TagRId ==. E.val k)
-  where
-    k = entityKey e
+-- deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
+-- deleteTag e = deleteE $ do
+--   c <- E.from $ E.table @TagR
+--   E.where_ (c ^. TagRId ==. E.val k)
+--   where
+--     k = entityKey e
 
--- TODO slip-n-slide code...
-insertFull
-  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
-  => Entity r
-  -> m ()
-insertFull (Entity k v) = insertKey k v
-
-currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
+-- -- TODO slip-n-slide code...
+-- insertFull
+--   :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
+--   => Entity r
+--   -> m ()
+-- insertFull (Entity k v) = insertKey k v
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap =
@@ -198,40 +380,35 @@ currencyMap =
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
-tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
-tree2Entity t parents name des =
-  Entity (toSqlKey $ fromIntegral h) $
-    AccountR name (toPath parents) des (accountSign t)
+parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
+parentEntity t parents name des =
+  Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
   where
-    p = AcntPath t (reverse (name : parents))
+    p = AcntPath t (name : parents)
     h = hash p
-    toPath = T.intercalate "/" . (atName t :) . reverse
 
-tree2Records
-  :: AcntType
-  -> AccountTree
-  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))])
+tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
-      let e = tree2Entity t (fmap snd ps) n d
+      let e = parentEntity t (fmap snd ps) n d
           k = entityKey e
-          (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
+          (as, aps) = L.unzip $ fmap (go ((k, n) : ps)) cs
           a0 = acnt k n (fmap snd ps) d
           paths = expand k $ fmap fst ps
-       in (a0 : concat as, paths ++ concat aps, concat ms)
+       in (a0 : concat as, paths ++ concat aps)
     go ps (Account d n) =
-      let e = tree2Entity t (fmap snd ps) n d
+      let e = parentEntity t (fmap snd ps) n d
           k = entityKey e
-       in ( [acnt k n (fmap snd ps) d]
-          , expand k $ fmap fst ps
-          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))]
-          )
-    toPath = T.intercalate "/" . (atName t :) . reverse
-    acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign
-    expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
+       in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
+    acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
+    expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
     sign = accountSign t
 
+accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
+accountPathRecord p c d =
+  Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
+
 paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
 paths2IDs =
   uncurry zip
@@ -290,14 +467,18 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
     ++ ((AssetT,) <$> arAssets)
     ++ ((EquityT,) <$> arEquity)
 
-indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
-indexAcntRoot r =
-  ( concat ars
-  , concat aprs
-  , M.fromList $ paths2IDs $ concat ms
-  )
+makeAcntMap :: [Entity AccountR] -> AccountMap
+makeAcntMap =
+  M.fromList
+    . paths2IDs
+    . fmap go
+    . filter (accountRLeaf . snd)
+    . fmap (\e -> (E.entityKey e, E.entityVal e))
   where
-    (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
+    go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
+
+indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
+indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
 getDBState
   :: (MonadInsertError m, MonadSqlQuery m)
@@ -310,7 +491,7 @@ getDBState c bs hs = do
   combineError bi si $ \b s ->
     ( DBState
         { kmCurrency = currencyMap cs
-        , kmAccount = am
+        , kmAccount = undefined
         , kmBudgetInterval = b
         , kmStatementInterval = s
         , kmTag = tagMap ts
@@ -319,7 +500,7 @@ getDBState c bs hs = do
     , DBUpdates
         { duOldCommits = del
         , duNewTagIds = ts
-        , duNewAcntPaths = paths
+        , duNewAcntPaths = undefined
         , duNewAcntIds = acnts
         , duNewCurrencyIds = cs
         }
@@ -327,7 +508,7 @@ getDBState c bs hs = do
   where
     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
-    (acnts, paths, am) = indexAcntRoot $ accounts c
+    (acnts, _) = indexAcntRoot $ accounts c
     cs = currency2Record <$> currencies c
     ts = toRecord <$> tags c
     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
@@ -336,35 +517,61 @@ getDBState c bs hs = do
 updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
 
-updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateTags DBUpdates {duNewTagIds} = do
-  tags' <- selectE $ E.from $ E.table @TagR
-  let (toIns, toDel) = setDiff duNewTagIds tags'
-  mapM_ deleteTag toDel
-  mapM_ insertFull toIns
+-- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateTags DBUpdates {duNewTagIds} = do
+--   tags' <- selectE $ E.from $ E.table @TagR
+--   let (toIns, toDel) = setDiff2 duNewTagIds tags'
+--   mapM_ deleteTag toDel
+--   mapM_ insertFull toIns
 
-updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
-  acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff duNewAcntIds acnts'
-  deleteWhere ([] :: [Filter AccountPathR])
-  mapM_ deleteAccount toDel
-  mapM_ insertFull toIns
-  mapM_ insert duNewAcntPaths
+-- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
+--   acnts' <- dumpTbl
+--   let (toIns, toDel) = setDiff2 duNewAcntIds acnts'
+--   deleteWhere ([] :: [Filter AccountPathR])
+--   mapM_ deleteAccount toDel
+--   mapM_ insertFull toIns
+--   mapM_ insert duNewAcntPaths
 
-updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateCurrencies DBUpdates {duNewCurrencyIds} = do
-  curs' <- selectE $ E.from $ E.table @CurrencyR
-  let (toIns, toDel) = setDiff duNewCurrencyIds curs'
-  mapM_ deleteCurrency toDel
-  mapM_ insertFull toIns
+-- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateCurrencies DBUpdates {duNewCurrencyIds} = do
+--   curs' <- selectE $ E.from $ E.table @CurrencyR
+--   let (toIns, toDel) = setDiff2 duNewCurrencyIds curs'
+--   mapM_ deleteCurrency toDel
+--   mapM_ insertFull toIns
 
-updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateDBState u = do
-  updateHashes u
-  updateTags u
-  updateAccounts u
-  updateCurrencies u
+updateCD
+  :: ( MonadSqlQuery m
+     , PersistRecordBackend a SqlBackend
+     , PersistRecordBackend b SqlBackend
+     )
+  => CDOps (Entity a) (Key b)
+  -> m ()
+updateCD (CRUDOps cs () () ds) = do
+  mapM_ deleteKeyE ds
+  insertEntityManyE cs
+
+deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
+deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
+  mapM_ deleteKeyE dtTxs
+  mapM_ deleteKeyE dtEntrySets
+  mapM_ deleteKeyE dtEntries
+  mapM_ deleteKeyE dtTagRelations
+
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState = do
+  updateCD =<< asks csCurrencies
+  updateCD =<< asks csAccounts
+  updateCD =<< asks csPaths
+  updateCD =<< asks csTags
+  deleteTxs =<< asks (coDelete . csBudgets)
+  deleteTxs =<< asks (coDelete . csHistTrans)
+  deleteTxs =<< asks (coDelete . csHistStmts)
+
+-- updateHashes u
+-- updateTags u
+-- updateAccounts u
+-- updateCurrencies u
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
@@ -372,54 +579,95 @@ deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
 selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
 selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
 
-whenHash
-  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
-  => ConfigType
-  -> a
-  -> b
-  -> (CommitRId -> m b)
-  -> m b
-whenHash t o def f = do
-  let h = hash o
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then f =<< insert (CommitR h t) else return def
+deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
+deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
 
-whenHash0
-  :: (Hashable a, MonadFinance m)
-  => ConfigType
-  -> a
-  -> b
-  -> (CommitR -> m b)
-  -> m b
-whenHash0 t o def f = do
-  let h = hash o
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then f (CommitR h t) else return def
+insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
+insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
 
-eitherHash
-  :: (Hashable a, MonadFinance m)
-  => ConfigType
-  -> a
-  -> (CommitR -> m b)
-  -> (CommitR -> m c)
-  -> m (Either b c)
-eitherHash t o f g = do
-  let h = hash o
-  let c = CommitR h t
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then Right <$> g c else Left <$> f c
+-- whenHash
+--   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
+--   => ConfigType
+--   -> a
+--   -> b
+--   -> (CommitRId -> m b)
+--   -> m b
+-- whenHash t o def f = do
+--   let h = hash o
+--   hs <- askDBState kmNewCommits
+--   if h `elem` hs then f =<< insert (CommitR h t) else return def
 
-whenHash_
-  :: (Hashable a, MonadFinance m)
-  => ConfigType
-  -> a
-  -> m b
-  -> m (Maybe (CommitR, b))
-whenHash_ t o f = do
-  let h = hash o
-  let c = CommitR h t
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then Just . (c,) <$> f else return Nothing
+-- whenHash0
+--   :: (Hashable a, MonadFinance m)
+--   => ConfigType
+--   -> a
+--   -> b
+--   -> (CommitR -> m b)
+--   -> m b
+-- whenHash0 t o def f = do
+--   let h = hash o
+--   hs <- askDBState kmNewCommits
+--   if h `elem` hs then f (CommitR h t) else return def
+
+-- eitherHash
+--   :: (Hashable a, MonadFinance m)
+--   => ConfigType
+--   -> a
+--   -> (CommitR -> m b)
+--   -> (CommitR -> m c)
+--   -> m (Either b c)
+-- eitherHash t o f g = do
+--   let h = hash o
+--   let c = CommitR h t
+--   hs <- askDBState kmNewCommits
+--   if h `elem` hs then Right <$> g c else Left <$> f c
+
+-- whenHash_
+--   :: (Hashable a, MonadFinance m)
+--   => ConfigType
+--   -> a
+--   -> m b
+--   -> m (Maybe (CommitR, b))
+-- whenHash_ t o f = do
+--   let h = hash o
+--   let c = CommitR h t
+--   hs <- askDBState kmNewCommits
+--   if h `elem` hs then Just . (c,) <$> f else return Nothing
+
+readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int])
+readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
+  rs <- selectE $ do
+    (commits :& _ :& entrysets :& entries :& tags) <-
+      E.from
+        $ E.table
+          `E.innerJoin` E.table
+        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
+          `E.innerJoin` E.table
+        `E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry)
+    E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
+    return
+      ( commits ^. CommitRHash
+      , entrysets ^. EntrySetRCurrency
+      , entries ^. EntryRAccount
+      , tags ^. TagRelationRTag
+      )
+  -- TODO there are faster ways to do this; may/may not matter
+  let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs
+  let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs
+  let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs
+  let valid = (cs `HS.intersection` as) `HS.intersection` ts
+  return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs
+  where
+    go existing f =
+      HS.fromList
+        . fmap (E.unValue . fst)
+        . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
+        . groupKey id
+        . fmap f
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
@@ -457,10 +705,12 @@ readUpdates hashes = do
       )
   let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
   toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
-  return (makeRE . snd <$> toRead, toUpdate')
+  let toRead' = fmap (makeRE . snd) toRead
+  return (toRead', toUpdate')
   where
     makeUES ((_, day, name, pri, (curID, prec)), es) = do
       let prec' = fromIntegral $ E.unValue prec
+      let cur = E.unValue curID
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -477,7 +727,7 @@ readUpdates hashes = do
               Left $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -492,7 +742,7 @@ readUpdates hashes = do
               Right $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -504,7 +754,7 @@ readUpdates hashes = do
                   , utPriority = E.unValue pri
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, pri, (curID, prec)), entry) =
+    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 5cef870..7d54047 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -9,8 +9,8 @@ import Control.Monad.Except
 import Data.Csv
 import Data.Decimal
 import Data.Foldable
+import Data.Hashable
 import GHC.Real
-import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -39,10 +39,12 @@ splitHistory = partitionEithers . fmap go
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => PairedTransfer
-  -> m (Either CommitR [Tx CommitR])
-readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
-  bounds <- askDBState kmStatementInterval
+  -> m [Tx CommitR]
+readHistTransfer ht = do
+  bounds <- askDBState csHistoryScope
   expandTransfer c historyName bounds ht
+  where
+    c = CommitR (hash ht) CTTransfer
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -51,11 +53,13 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [Tx CommitR])
-readHistStmt root i = eitherHash CTImport i return $ \c -> do
+  -> m [Tx CommitR]
+readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState kmStatementInterval
+  bounds <- askDBState csHistoryScope
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
+  where
+    c = CommitR (hash i) CTTransfer
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@@ -78,7 +82,7 @@ readImport_
   -> m [TxRecord]
 readImport_ n delim tns p = do
   res <- tryIO $ BL.readFile p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
     Left m -> throwIO $ InsertException [ParseError $ T.pack m]
     Right (_, v) -> return $ catMaybes $ V.toList v
@@ -313,7 +317,7 @@ toTx
         }
     where
       curRes = do
-        m <- askDBState kmCurrency
+        m <- askDBState csCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -327,7 +331,7 @@ resolveSubGetter
   -> TxSubGetter
   -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- askDBState kmCurrency
+  m <- askDBState csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 1d4be04..9ece6d0 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -14,6 +14,7 @@ import RIO
 import qualified RIO.Text as T
 import RIO.Time
 
+-- TODO use newtypes for all the different numbers so they don't get mixed up
 share
   [mkPersist sqlSettings, mkMigrate "migrateAll"]
   [persistLowerCase|
@@ -21,20 +22,24 @@ CommitR sql=commits
     hash Int
     type ConfigType
     deriving Show Eq Ord
+ConfigStateR sql=config_state
+    historyScopeHash Int
+    budgetScopeHash Int
 CurrencyR sql=currencies
-    symbol T.Text
+    symbol CurID
     fullname T.Text
     precision Int
     deriving Show Eq
 TagR sql=tags
-    symbol T.Text
+    symbol TagID
     fullname T.Text
     deriving Show Eq
 AccountR sql=accounts
     name T.Text
-    fullpath T.Text
+    fullpath AcntPath
     desc T.Text
     sign AcntSign
+    leaf Bool
     deriving Show Eq
 AccountPathR sql=account_paths
     parent AccountRId OnDeleteCascade
@@ -70,7 +75,7 @@ TagRelationR sql=tag_relations
     deriving Show Eq
 |]
 
-data ConfigType = CTBudget | CTManual | CTImport
+data ConfigType = CTBudget | CTTransfer | CTHistory
   deriving (Eq, Show, Read, Enum, Ord)
 
 instance PersistFieldSql ConfigType where
@@ -97,3 +102,38 @@ instance PersistField AcntSign where
   fromPersistValue (PersistInt64 (-1)) = Right Credit
   fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
   fromPersistValue _ = Left "not an Int64"
+
+data AcntType
+  = AssetT
+  | EquityT
+  | ExpenseT
+  | IncomeT
+  | LiabilityT
+  deriving (Show, Eq, Ord, Hashable, Generic, Read)
+
+atName :: AcntType -> T.Text
+atName AssetT = "asset"
+atName EquityT = "equity"
+atName ExpenseT = "expense"
+atName IncomeT = "income"
+atName LiabilityT = "liability"
+
+data AcntPath = AcntPath
+  { apType :: !AcntType
+  , apChildren :: ![T.Text]
+  }
+  deriving (Eq, Ord, Show, Hashable, Generic, Read)
+
+instance PersistFieldSql AcntPath where
+  sqlType _ = SqlString
+
+instance PersistField AcntPath where
+  toPersistValue (AcntPath t cs) =
+    PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
+
+  fromPersistValue (PersistText v) = case T.split (== '/') v of
+    [] -> Left "path is empty"
+    (x : xs) -> case readMaybe $ T.unpack x of
+      Just t -> Right $ AcntPath t $ reverse xs
+      _ -> Left "could not get account type"
+  fromPersistValue _ = Left "not a string"
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 5cb6af0..a4b6ba4 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -371,7 +371,7 @@ data AccountRoot_ a = AccountRoot_
   , arIncome :: ![a]
   , arLiabilities :: ![a]
   }
-  deriving (Generic)
+  deriving (Generic, Hashable)
 
 type AccountRootF = AccountRoot_ (Fix AccountTreeF)
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 2e36bc2..5d96fb7 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -17,7 +16,6 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Dhall hiding (embed, maybe)
 import Internal.Types.Database
 import Internal.Types.Dhall
-import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
@@ -35,6 +33,36 @@ data ConfigHashes = ConfigHashes
   , chImport :: ![Int]
   }
 
+data DeleteTxs = DeleteTxs
+  { dtTxs :: ![TransactionRId]
+  , dtEntrySets :: ![EntrySetRId]
+  , dtEntries :: ![EntryRId]
+  , dtTagRelations :: ![TagRelationRId]
+  }
+
+type CDOps c d = CRUDOps [c] () () [d]
+
+data ConfigState = ConfigState
+  { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
+  , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
+  , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
+  , csTags :: !(CDOps (Entity TagR) TagRId)
+  , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csAccountMap :: !AccountMap
+  , csCurrencyMap :: !CurrencyMap
+  , csTagMap :: !TagMap
+  , csBudgetScope :: !DaySpan
+  , csHistoryScope :: !DaySpan
+  }
+
+data ExistingConfig = ExistingConfig
+  { ecAccounts :: !(HashSet Int)
+  , ecTags :: !(HashSet Int)
+  , ecCurrencies :: !(HashSet Int)
+  }
+
 type AccountMap = M.Map AcntID (AccountRId, AcntType)
 
 data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
@@ -44,6 +72,23 @@ type CurrencyMap = M.Map CurID CurrencyPrec
 
 type TagMap = M.Map TagID TagRId
 
+data CRUDOps c r u d = CRUDOps
+  { coCreate :: !c
+  , coRead :: !r
+  , coUpdate :: !u
+  , coDelete :: !d
+  }
+
+data DBState_ = DBState_
+  { dbsCurrencyMap :: !CurrencyMap
+  , dbsAccountMap :: !AccountMap
+  , dbsTagMap :: !TagMap
+  , dbsBudgetInterval :: !DaySpan
+  , dbsHistoryInterval :: !DaySpan
+  , dbsNewCommits :: ![Int]
+  }
+  deriving (Show)
+
 data DBState = DBState
   { kmCurrency :: !CurrencyMap
   , kmAccount :: !AccountMap
@@ -63,8 +108,6 @@ data DBUpdates = DBUpdates
   }
   deriving (Show)
 
-type CurrencyM = Reader CurrencyMap
-
 data DBDeferred
   = DBEntryLinked Natural Double
   | DBEntryBalance Decimal
@@ -138,35 +181,14 @@ data EntryBin
 
 type TreeR = Tree ([T.Text], AccountRId)
 
-type MonadFinance = MonadReader DBState
+type MonadFinance = MonadReader ConfigState
 
-askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState :: MonadFinance m => (ConfigState -> a) -> m a
 askDBState = asks
 
 -------------------------------------------------------------------------------
 -- misc
 
-data AcntType
-  = AssetT
-  | EquityT
-  | ExpenseT
-  | IncomeT
-  | LiabilityT
-  deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
-
-atName :: AcntType -> T.Text
-atName AssetT = "asset"
-atName EquityT = "equity"
-atName ExpenseT = "expense"
-atName IncomeT = "income"
-atName LiabilityT = "liability"
-
-data AcntPath = AcntPath
-  { apType :: !AcntType
-  , apChildren :: ![T.Text]
-  }
-  deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
-
 data TxRecord = TxRecord
   { trDate :: !Day
   , trAmount :: !Decimal
@@ -178,19 +200,8 @@ data TxRecord = TxRecord
 
 type DaySpan = (Day, Natural)
 
-data Keyed a = Keyed
-  { kKey :: !Int64
-  , kVal :: !a
-  }
-  deriving (Eq, Show, Functor)
-
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
--- TODO debit should be negative
-sign2Int :: AcntSign -> Int
-sign2Int Debit = 1
-sign2Int Credit = 1
-
 accountSign :: AcntType -> AcntSign
 accountSign AssetT = Debit
 accountSign ExpenseT = Debit
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index e5758be..c68490f 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -152,7 +152,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState kmBudgetInterval
+  globalSpan <- askDBState csBudgetScope
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -419,14 +419,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
--- roundPrecision :: Natural -> Double -> Rational
--- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
---   where
---     p = 10 ^ n
-
--- roundPrecisionCur :: CurrencyPrec -> Double -> Rational
--- roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
-
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 
@@ -638,7 +630,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
 lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
-lookupAccount = lookupFinance AcntField kmAccount
+lookupAccount = lookupFinance AcntField csAccountMap
 
 lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
 lookupAccountKey = fmap fst . lookupAccount
@@ -647,7 +639,7 @@ lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntTyp
 lookupAccountType = fmap snd . lookupAccount
 
 lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
-lookupCurrency = lookupFinance CurField kmCurrency
+lookupCurrency = lookupFinance CurField csCurrencyMap
 
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
@@ -656,12 +648,12 @@ lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precis
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
-lookupTag = lookupFinance TagField kmTag
+lookupTag = lookupFinance TagField csTagMap
 
 lookupFinance
   :: (MonadInsertError m, MonadFinance m)
   => EntryIDType
-  -> (DBState -> M.Map T.Text a)
+  -> (ConfigState -> M.Map T.Text a)
   -> T.Text
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
@@ -865,7 +857,7 @@ balancePrimaryEntrySet
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
           let balFrom = fmap liftInnerS . balanceDeferred
-          fs'' <- doEntries balFrom bc esTotalValue f0' fs'
+          fs'' <- balanceTotalEntrySet balFrom bc esTotalValue f0' fs'
           balanceFinal bc (-esTotalValue) fs'' t0' ts'
 
 balanceSecondaryEntrySet
@@ -904,7 +896,7 @@ balanceFinal
 balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
   let balTo = balanceLinked fv
-  ts' <- doEntries balTo k tot t0 ts
+  ts' <- balanceTotalEntrySet balTo k tot t0 ts
   return $
     InsertEntrySet
       { iesCurrency = curID
@@ -912,7 +904,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
       , iesToEntries = ts'
       }
 
-doEntries
+balanceTotalEntrySet
   :: (MonadInsertError m)
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
@@ -920,7 +912,7 @@ doEntries
   -> Entry AccountRId () TagRId
   -> [Entry AccountRId v TagRId]
   -> StateT EntryBals m (NonEmpty InsertEntry)
-doEntries f k tot e@Entry {eAcnt = acntID} es = do
+balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
   es' <- mapErrors (balanceEntry f k) es
   let e0val = tot - entrySum es'
   -- TODO not dry

From 0e74ae41dba09d31cfaa7e2bf8f156cf7f9cbdd0 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 13 Jul 2023 23:43:10 -0400
Subject: [PATCH 50/59] FIX reversed account path

---
 lib/Internal/Database.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 83fe253..50bbe03 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -417,8 +417,7 @@ paths2IDs =
     . L.sortOn fst
     . fmap (first pathList)
   where
-    pathList (AcntPath t []) = atName t :| []
-    pathList (AcntPath t ns) = NE.reverse $ atName t :| ns
+    pathList (AcntPath t ns) = NE.reverse $ atName t :| reverse ns
 
 -- none of these errors should fire assuming that input is sorted and unique
 trimNames :: [NE.NonEmpty T.Text] -> [AcntID]

From 223be34145509b1690739bb819249bcd434e8e2e Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 15 Jul 2023 14:14:23 -0400
Subject: [PATCH 51/59] FIX mixed up account paths/keys

---
 app/Main.hs                    |   3 +
 lib/Internal/Database.hs       | 244 ++++++++++++++++++---------------
 lib/Internal/Types/Database.hs |  12 +-
 lib/Internal/Utils.hs          |   8 +-
 4 files changed, 150 insertions(+), 117 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index dc5d97f..1af3fc0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -20,6 +20,7 @@ import Internal.Utils
 import Options.Applicative
 import RIO
 import RIO.FilePath
+import qualified RIO.Map as M
 import qualified RIO.Text as T
 
 main :: IO ()
@@ -232,6 +233,8 @@ runSync threads c bs hs = do
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
+        (liftIO . print) =<< askDBState (M.keys . csAccountMap)
+        -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         -- lift $ setNumCapabilities 1
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 50bbe03..8fb0523 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -4,7 +4,7 @@ module Internal.Database
   , nukeTables
   , updateHashes
   , updateDBState
-  , getDBState
+  -- , getDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -289,22 +289,22 @@ readCurrentCommits = do
             CTTransfer -> (bs, y : ts, hs)
             CTHistory -> (bs, ts, y : hs)
 
-hashConfig :: [Budget] -> [History] -> [Int]
-hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
-  where
-    (ms, ps) = partitionEithers $ fmap go hs
-    go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
+-- hashConfig :: [Budget] -> [History] -> [Int]
+-- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
+--   where
+--     (ms, ps) = partitionEithers $ fmap go hs
+--     go (HistTransfer x) = Left x
+--     go (HistStatement x) = Right x
 
-setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
-setDiff2 = setDiffWith2 (==)
+-- setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
+-- setDiff2 = setDiffWith2 (==)
 
--- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
--- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
+-- -- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
+-- -- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
 
--- setDiff as bs = (as \\ bs, bs \\ as)
-setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
-setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
+-- -- setDiff as bs = (as \\ bs, bs \\ as)
+-- setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
+-- setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
 
 setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
 setDiffWith f = go [] []
@@ -319,8 +319,8 @@ setDiffWith f = go [] []
       | f a b = Just (b, bs)
       | otherwise = inB a bs
 
-getDBHashes :: MonadSqlQuery m => m [Int]
-getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
+-- getDBHashes :: MonadSqlQuery m => m [Int]
+-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
 
 nukeDBHash :: MonadSqlQuery m => Int -> m ()
 nukeDBHash h = deleteE $ do
@@ -330,11 +330,11 @@ nukeDBHash h = deleteE $ do
 nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
-getConfigHashes bs hs = do
-  let ch = hashConfig bs hs
-  dh <- getDBHashes
-  return $ setDiff2 dh ch
+-- getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
+-- getConfigHashes bs hs = do
+--   let ch = hashConfig bs hs
+--   dh <- getDBHashes
+--   return $ setDiff2 dh ch
 
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
@@ -380,30 +380,32 @@ currencyMap =
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
-parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
-parentEntity t parents name des =
-  Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
+makeAccountEntity :: AccountR -> Entity AccountR
+makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
+
+makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
+makeAccountR atype name parents des = AccountR name path des (accountSign atype)
   where
-    p = AcntPath t (name : parents)
-    h = hash p
+    path = AcntPath atype (reverse $ name : parents)
 
 tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
-      let e = parentEntity t (fmap snd ps) n d
-          k = entityKey e
-          (as, aps) = L.unzip $ fmap (go ((k, n) : ps)) cs
-          a0 = acnt k n (fmap snd ps) d
-          paths = expand k $ fmap fst ps
-       in (a0 : concat as, paths ++ concat aps)
+      let (parentKeys, parentNames) = L.unzip ps
+          a = acnt n parentNames d False
+          k = entityKey a
+          thesePaths = expand k parentKeys
+       in bimap ((a :) . concat) ((thesePaths ++) . concat) $
+            L.unzip $
+              go ((k, n) : ps) <$> cs
     go ps (Account d n) =
-      let e = parentEntity t (fmap snd ps) n d
-          k = entityKey e
-       in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
-    acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
+      let (parentKeys, parentNames) = L.unzip ps
+          a = acnt n parentNames d True
+          k = entityKey a
+       in ([a], expand k parentKeys)
     expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
-    sign = accountSign t
+    acnt n ps d = makeAccountEntity . makeAccountR t n ps d
 
 accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
 accountPathRecord p c d =
@@ -415,48 +417,74 @@ paths2IDs =
     . first trimNames
     . L.unzip
     . L.sortOn fst
-    . fmap (first pathList)
-  where
-    pathList (AcntPath t ns) = NE.reverse $ atName t :| reverse ns
+    . fmap (first (NE.reverse . acntPath2NonEmpty))
+
+-- -- none of these errors should fire assuming that input is sorted and unique
+-- trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
+-- trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
+--   where
+--     trimAll _ [] = []
+--     trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
+--       (a, [], bs) -> reverse $ trim i a : bs
+--       (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
+--     matchPre i (y, ys, old) new = case (y !? i, new !? i) of
+--       (Nothing, Just _) ->
+--         case ys of
+--           [] -> (new, [], trim i y : old)
+--           _ -> err "unsorted input"
+--       (Just _, Nothing) -> err "unsorted input"
+--       (Nothing, Nothing) -> err "duplicated inputs"
+--       (Just a, Just b)
+--         | a == b -> (new, y : ys, old)
+--         | otherwise ->
+--             let next = case ys of
+--                   [] -> [trim i y]
+--                   _ -> trimAll (i + 1) (reverse $ y : ys)
+--              in (new, [], reverse next ++ old)
+--     trim i = NE.take (i + 1)
+--     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
 
 -- none of these errors should fire assuming that input is sorted and unique
-trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
-trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
+trimNames :: [NonEmpty T.Text] -> [AcntID]
+trimNames = fmap (T.intercalate "_") . go []
   where
-    trimAll _ [] = []
-    trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
-      (a, [], bs) -> reverse $ trim i a : bs
-      (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
-    matchPre i (y, ys, old) new = case (y !? i, new !? i) of
-      (Nothing, Just _) ->
-        case ys of
-          [] -> (new, [], trim i y : old)
-          _ -> err "unsorted input"
-      (Just _, Nothing) -> err "unsorted input"
-      (Nothing, Nothing) -> err "duplicated inputs"
-      (Just a, Just b)
-        | a == b -> (new, y : ys, old)
-        | otherwise ->
-            let next = case ys of
-                  [] -> [trim i y]
-                  _ -> trimAll (i + 1) (reverse $ y : ys)
-             in (new, [], reverse next ++ old)
-    trim i = NE.take (i + 1)
-    err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
+    go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
+    go prev = concatMap (go' prev) . groupNonEmpty
+    go' prev (key, rest) = case rest of
+      (_ :| []) -> [key : prev]
+      ([] :| xs) ->
+        let next = key : prev
+            other = go next $ fmap (fromMaybe undefined . NE.nonEmpty) xs
+         in next : other
+      (x :| xs) -> go (key : prev) $ fmap (fromMaybe undefined . NE.nonEmpty) (x : xs)
 
-(!?) :: NE.NonEmpty a -> Int -> Maybe a
-xs !? n
-  | n < 0 = Nothing
-  -- Definition adapted from GHC.List
-  | otherwise =
-      foldr
-        ( \x r k -> case k of
-            0 -> Just x
-            _ -> r (k - 1)
-        )
-        (const Nothing)
-        xs
-        n
+groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
+groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
+
+-- groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, (Maybe a, [NonEmpty a]))]
+-- groupNonEmpty = fmap (second (go <$>)) . groupWith NE.head
+--   where
+--     go xs = case NE.nonEmpty $ NE.tail xs of
+--       (x :| [])
+
+-- where
+--   go xs@((key :| _) :| _) = (key, xs)
+
+-- go (x :| xs) = (x, Just xs)
+
+-- (!?) :: NE.NonEmpty a -> Int -> Maybe a
+-- xs !? n
+--   | n < 0 = Nothing
+--   -- Definition adapted from GHC.List
+--   | otherwise =
+--       foldr
+--         ( \x r k -> case k of
+--             0 -> Just x
+--             _ -> r (k - 1)
+--         )
+--         (const Nothing)
+--         xs
+--         n
 
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
 flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
@@ -479,39 +507,39 @@ makeAcntMap =
 indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
 indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
-getDBState
-  :: (MonadInsertError m, MonadSqlQuery m)
-  => Config
-  -> [Budget]
-  -> [History]
-  -> m (DBState, DBUpdates)
-getDBState c bs hs = do
-  (del, new) <- getConfigHashes bs hs
-  combineError bi si $ \b s ->
-    ( DBState
-        { kmCurrency = currencyMap cs
-        , kmAccount = undefined
-        , kmBudgetInterval = b
-        , kmStatementInterval = s
-        , kmTag = tagMap ts
-        , kmNewCommits = new
-        }
-    , DBUpdates
-        { duOldCommits = del
-        , duNewTagIds = ts
-        , duNewAcntPaths = undefined
-        , duNewAcntIds = acnts
-        , duNewCurrencyIds = cs
-        }
-    )
-  where
-    bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
-    si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
-    (acnts, _) = indexAcntRoot $ accounts c
-    cs = currency2Record <$> currencies c
-    ts = toRecord <$> tags c
-    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+-- getDBState
+--   :: (MonadInsertError m, MonadSqlQuery m)
+--   => Config
+--   -> [Budget]
+--   -> [History]
+--   -> m (DBState, DBUpdates)
+-- getDBState c bs hs = do
+--   (del, new) <- getConfigHashes bs hs
+--   combineError bi si $ \b s ->
+--     ( DBState
+--         { kmCurrency = currencyMap cs
+--         , kmAccount = undefined
+--         , kmBudgetInterval = b
+--         , kmStatementInterval = s
+--         , kmTag = tagMap ts
+--         , kmNewCommits = new
+--         }
+--     , DBUpdates
+--         { duOldCommits = del
+--         , duNewTagIds = ts
+--         , duNewAcntPaths = undefined
+--         , duNewAcntIds = acnts
+--         , duNewCurrencyIds = cs
+--         }
+--     )
+--   where
+--     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
+--     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
+--     (acnts, _) = indexAcntRoot $ accounts c
+--     cs = currency2Record <$> currencies c
+--     ts = toRecord <$> tags c
+--     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+--     tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
 updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 9ece6d0..17ca681 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -11,6 +11,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
 import Internal.Types.Dhall
 import RIO
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
@@ -124,16 +125,21 @@ data AcntPath = AcntPath
   }
   deriving (Eq, Ord, Show, Hashable, Generic, Read)
 
+acntPath2Text :: AcntPath -> T.Text
+acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
+
+acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
+acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
+
 instance PersistFieldSql AcntPath where
   sqlType _ = SqlString
 
 instance PersistField AcntPath where
-  toPersistValue (AcntPath t cs) =
-    PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
+  toPersistValue = PersistText . acntPath2Text
 
   fromPersistValue (PersistText v) = case T.split (== '/') v of
     [] -> Left "path is empty"
     (x : xs) -> case readMaybe $ T.unpack x of
-      Just t -> Right $ AcntPath t $ reverse xs
+      Just t -> Right $ AcntPath t xs
       _ -> Left "could not get account type"
   fromPersistValue _ = Left "not a string"
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index c68490f..b3a8e54 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -29,7 +29,6 @@ module Internal.Utils
   , mapErrorsIO
   , mapErrorsPooledIO
   , showError
-  , acntPath2Text
   , tshow
   , lookupErr
   , gregorians
@@ -419,9 +418,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
-acntPath2Text :: AcntPath -> T.Text
-acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
-
 --------------------------------------------------------------------------------
 -- error display
 
@@ -618,10 +614,10 @@ groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
     go xs@((c, _) :| _) = (c, fmap snd xs)
 
-groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
+groupWith :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
 groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
   where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+    go xs@((c, _) :| _) = (c, fmap snd xs)
 
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
 mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k

From 8901fd6a64ee58da67e88a40322982a492bd0633 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 15 Jul 2023 23:25:28 -0400
Subject: [PATCH 52/59] FIX update bugs

---
 app/Main.hs                    |  24 +++--
 lib/Internal/Budget.hs         |   2 +-
 lib/Internal/Database.hs       | 166 ++++++++++++++++-----------------
 lib/Internal/History.hs        |   8 +-
 lib/Internal/Types/Database.hs |  47 ++++++----
 lib/Internal/Types/Main.hs     |  15 +--
 lib/Internal/Utils.hs          |   2 +-
 7 files changed, 144 insertions(+), 120 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 1af3fc0..4304bc0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -8,6 +8,7 @@ import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Data.Bitraversable
+-- import Data.Hashable
 import qualified Data.Text.IO as TI
 import qualified Database.Esqueleto.Experimental as E
 import Database.Persist.Monad
@@ -20,7 +21,7 @@ import Internal.Utils
 import Options.Applicative
 import RIO
 import RIO.FilePath
-import qualified RIO.Map as M
+-- import qualified RIO.Map as M
 import qualified RIO.Text as T
 
 main :: IO ()
@@ -233,7 +234,7 @@ runSync threads c bs hs = do
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
-        (liftIO . print) =<< askDBState (M.keys . csAccountMap)
+        -- (liftIO . print) =<< askDBState (M.keys . csAccountMap)
         -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
@@ -247,12 +248,19 @@ runSync threads c bs hs = do
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         -- lift $ print $ length $ lefts bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
-    -- print $ length $ kmNewCommits state
-    -- print $ length $ duOldCommits updates
-    -- print $ length $ duNewTagIds updates
-    -- print $ length $ duNewAcntPaths updates
-    -- print $ length $ duNewAcntIds updates
-    -- print $ length $ duNewCurrencyIds updates
+    print $ length $ coCreate $ csBudgets state
+    print $ length $ coCreate $ csHistTrans state
+    print $ length $ coCreate $ csHistStmts state
+    print $ length $ coUpdate $ csBudgets state
+    print $ length $ coUpdate $ csHistTrans state
+    print $ length $ coUpdate $ csHistStmts state
+    print $ length $ coRead $ csBudgets state
+    print $ length $ coRead $ csHistTrans state
+    print $ length $ coRead $ csHistStmts state
+    print $ coDelete $ csBudgets state
+    print $ coDelete $ csHistTrans state
+    print $ coDelete $ csHistStmts state
+    -- print $ fmap hash $ coCreate $ csHistStmts state
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 251701e..feeb26c 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -49,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState csBudgetScope
+        globalSpan <- askDBState (unBSpan . csBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 8fb0523..507e09c 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -22,7 +22,7 @@ import Control.Monad.Except
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
-import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
+import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
@@ -42,11 +42,10 @@ import GHC.Err
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
-import qualified RIO.HashSet as HS
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
--- import qualified RIO.Set as S
+import qualified RIO.Set as S
 import qualified RIO.Text as T
 
 runDB
@@ -126,67 +125,66 @@ readConfigState
   -> [History]
   -> m ConfigState
 readConfigState c bs hs = do
-  curAcnts <- readCurrentIds AccountRId
-  curTags <- readCurrentIds TagRId
-  curCurs <- readCurrentIds CurrencyRId
-  curPaths <- readCurrentIds AccountPathRId
-  let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts
-  let (pathsIns, _, pathsDel) = diff newPaths curPaths
-  let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs
-  let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags
+  (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
+  (pathsIns, _, pathsDel) <- diff newPaths
+  (curs2Ins, cursRem, curs2Del) <- diff newCurs
+  (tags2Ins, tagsRem, tags2Del) <- diff newTags
   let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
   let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
   let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
-  let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
+  let fromMap f = S.fromList . fmap f . M.elems
   let existing =
         ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
 
   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-  (bChanged, hChanged) <- readScopeChanged $ scope c
-  bgt <- makeTxCRUD existing bs curBgts bChanged
-  hTrans <- makeTxCRUD existing ts curHistTrs hChanged
-  hStmt <- makeTxCRUD existing ss curHistSts hChanged
+  -- TODO refine this test to include the whole db (with data already mixed
+  -- in this algorithm)
+  let bsRes = BudgetSpan <$> resolveScope budgetInterval
+  let hsRes = HistorySpan <$> resolveScope statementInterval
+  combineErrorM bsRes hsRes $ \bscope hscope -> do
+    let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
+    (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
+    bgt <- makeTxCRUD existing bs curBgts bChanged
+    hTrans <- makeTxCRUD existing ts curHistTrs hChanged
+    hStmt <- makeTxCRUD existing ss curHistSts hChanged
 
-  let bsRes = resolveScope budgetInterval
-  let hsRes = resolveScope statementInterval
-  combineError bsRes hsRes $ \b h ->
-    ConfigState
-      { csCurrencies = CRUDOps curs2Ins () () curs2Del
-      , csTags = CRUDOps tags2Ins () () tags2Del
-      , csAccounts = CRUDOps acnts2Ins () () acnts2Del
-      , csPaths = CRUDOps pathsIns () () pathsDel
-      , csBudgets = bgt
-      , csHistTrans = hTrans
-      , csHistStmts = hStmt
-      , csAccountMap = amap
-      , csCurrencyMap = cmap
-      , csTagMap = tmap
-      , csBudgetScope = b
-      , csHistoryScope = h
-      }
+    return $
+      ConfigState
+        { csCurrencies = CRUDOps curs2Ins () () curs2Del
+        , csTags = CRUDOps tags2Ins () () tags2Del
+        , csAccounts = CRUDOps acnts2Ins () () acnts2Del
+        , csPaths = CRUDOps pathsIns () () pathsDel
+        , csBudgets = bgt
+        , csHistTrans = hTrans
+        , csHistStmts = hStmt
+        , csAccountMap = amap
+        , csCurrencyMap = cmap
+        , csTagMap = tmap
+        , csBudgetScope = bscope
+        , csHistoryScope = hscope
+        }
   where
     (ts, ss) = splitHistory hs
-    diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a])
-    diff = setDiffWith (\a b -> E.entityKey a == b)
+    diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
     (newAcnts, newPaths) = indexAcntRoot $ accounts c
     newTags = tag2Record <$> tags c
     newCurs = currency2Record <$> currencies c
     resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
 
-readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool)
-readScopeChanged s = do
+readScopeChanged
+  :: (MonadInsertError m, MonadSqlQuery m)
+  => Bool
+  -> BudgetSpan
+  -> HistorySpan
+  -> m (Bool, Bool)
+readScopeChanged dbempty bscope hscope = do
   rs <- dumpTbl
   case rs of
-    [] -> return (True, True)
+    [] -> if dbempty then return (True, True) else throwError undefined
     [r] -> do
-      let (ConfigStateR hsh bsh) = E.entityVal r
-      return
-        ( hashScope budgetInterval == bsh
-        , hashScope statementInterval == hsh
-        )
+      let (ConfigStateR h b) = E.entityVal r
+      return (bscope /= b, hscope /= h)
     _ -> throwError undefined
-  where
-    hashScope f = hash $ f s
 
 makeTxCRUD
   :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
@@ -202,13 +200,13 @@ makeTxCRUD
           DeleteTxs
       )
 makeTxCRUD existing newThings curThings scopeChanged = do
-  let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings
+  let (toDelHashes, overlap, toIns) =
+        setDiffWith (\a b -> hash b == a) curThings newThings
   -- Check the overlap for rows with accounts/tags/currencies that
   -- won't exist on the next update. Those with invalid IDs will be set aside
   -- to delete and reinsert (which may also fail) later
-  (toInsRetry, noRetry) <- readInvalidIds existing overlap
-  let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
-  let toInsAll = (snd <$> toInsRetry) ++ toIns
+  (noRetry, toInsRetry) <- readInvalidIds existing overlap
+  let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
   -- If we are inserting or deleting something or the scope changed, pull out
   -- the remainder of the entries to update/read as we are (re)inserting other
   -- stuff (this is necessary because a given transaction may depend on the
@@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do
     _ -> readUpdates noRetry
   toDelAll <- readTxIds toDelAllHashes
   return $ CRUDOps toInsAll toRead toUpdate toDelAll
-  where
-    go a b = hash b == a
 
 readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
 readTxIds cs = do
@@ -270,10 +266,10 @@ currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
 
-readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a]
-readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do
+readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
+readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
   rs <- E.from E.table
-  return (rs ^. f)
+  return (rs ^. E.persistIdField)
 
 readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
 readCurrentCommits = do
@@ -286,8 +282,8 @@ readCurrentCommits = do
       let y = E.unValue x
        in case E.unValue t of
             CTBudget -> (y : bs, ts, hs)
-            CTTransfer -> (bs, y : ts, hs)
-            CTHistory -> (bs, ts, y : hs)
+            CTHistoryTransfer -> (bs, y : ts, hs)
+            CTHistoryStatement -> (bs, ts, y : hs)
 
 -- hashConfig :: [Budget] -> [History] -> [Int]
 -- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
@@ -311,13 +307,16 @@ setDiffWith f = go [] []
   where
     go inA inBoth [] bs = (inA, inBoth, bs)
     go inA inBoth as [] = (as ++ inA, inBoth, [])
-    go inA inBoth (a : as) bs = case inB a bs of
-      Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
-      Nothing -> go (a : inA) inBoth as bs
-    inB _ [] = Nothing
-    inB a (b : bs)
-      | f a b = Just (b, bs)
-      | otherwise = inB a bs
+    go inA inBoth (a : as) bs =
+      let (res, bs') = findDelete (f a) bs
+       in case res of
+            Nothing -> go (a : inA) inBoth as bs
+            Just b -> go inA ((a, b) : inBoth) as bs'
+
+findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
+findDelete f xs = case break f xs of
+  (ys, []) -> (Nothing, ys)
+  (ys, z : zs) -> (Just z, ys ++ zs)
 
 -- getDBHashes :: MonadSqlQuery m => m [Int]
 -- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@@ -594,23 +593,24 @@ updateDBState = do
   deleteTxs =<< asks (coDelete . csBudgets)
   deleteTxs =<< asks (coDelete . csHistTrans)
   deleteTxs =<< asks (coDelete . csHistStmts)
-
--- updateHashes u
--- updateTags u
--- updateAccounts u
--- updateCurrencies u
+  b <- asks csBudgetScope
+  h <- asks csHistoryScope
+  repsertE (E.toSqlKey 1) $ ConfigStateR h b
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
 
+repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
+repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
+
 selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
 selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
 
 deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
-deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
+deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
 
 insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
+insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
 
 -- whenHash
 --   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
 --   hs <- askDBState kmNewCommits
 --   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
-readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int])
+readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
     (commits :& _ :& entrysets :& entries :& tags) <-
@@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
         `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table
         `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry)
+          `E.leftJoin` E.table
+        `E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
     return
       ( commits ^. CommitRHash
       , entrysets ^. EntrySetRCurrency
       , entries ^. EntryRAccount
-      , tags ^. TagRelationRTag
+      , tags ?. TagRelationRTag
       )
   -- TODO there are faster ways to do this; may/may not matter
-  let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs
-  let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs
-  let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs
-  let valid = (cs `HS.intersection` as) `HS.intersection` ts
-  return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs
+  let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
+  let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
+  let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
+  let valid = (cs `S.intersection` as) `S.intersection` ts
+  let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
+  return (a0, [])
   where
-    go existing f =
-      HS.fromList
+    go existing =
+      S.fromList
         . fmap (E.unValue . fst)
-        . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
+        . L.filter (all (`S.member` existing) . snd)
         . groupKey id
-        . fmap f
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 7d54047..c3d2970 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -41,10 +41,10 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- askDBState csHistoryScope
+  bounds <- askDBState (unHSpan . csHistoryScope)
   expandTransfer c historyName bounds ht
   where
-    c = CommitR (hash ht) CTTransfer
+    c = CommitR (hash ht) CTHistoryTransfer
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -56,10 +56,10 @@ readHistStmt
   -> m [Tx CommitR]
 readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState csHistoryScope
+  bounds <- askDBState (unHSpan . csHistoryScope)
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
-    c = CommitR (hash i) CTTransfer
+    c = CommitR (hash i) CTHistoryStatement
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 17ca681..812363b 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -22,47 +22,54 @@ share
 CommitR sql=commits
     hash Int
     type ConfigType
+    UniqueCommitHash hash
     deriving Show Eq Ord
 ConfigStateR sql=config_state
-    historyScopeHash Int
-    budgetScopeHash Int
+    historySpan HistorySpan
+    budgetSpan BudgetSpan
+    deriving Show
 CurrencyR sql=currencies
     symbol CurID
     fullname T.Text
     precision Int
-    deriving Show Eq
+    UniqueCurrencySymbol symbol
+    UniqueCurrencyFullname fullname
+    deriving Show Eq Ord
 TagR sql=tags
     symbol TagID
     fullname T.Text
-    deriving Show Eq
+    UniqueTagSymbol symbol
+    UniqueTagFullname fullname
+    deriving Show Eq Ord
 AccountR sql=accounts
     name T.Text
     fullpath AcntPath
     desc T.Text
     sign AcntSign
     leaf Bool
-    deriving Show Eq
+    UniqueAccountFullpath fullpath
+    deriving Show Eq Ord
 AccountPathR sql=account_paths
-    parent AccountRId OnDeleteCascade
-    child AccountRId OnDeleteCascade
+    parent AccountRId 
+    child AccountRId 
     depth Int
-    deriving Show Eq
+    deriving Show Eq Ord
 TransactionR sql=transactions
-    commit CommitRId OnDeleteCascade
+    commit CommitRId 
     date Day
     description T.Text
     budgetName T.Text
     priority Int
     deriving Show Eq
 EntrySetR sql=entry_sets
-    transaction TransactionRId OnDeleteCascade
-    currency CurrencyRId OnDeleteCascade
+    transaction TransactionRId 
+    currency CurrencyRId 
     index Int
     rebalance Bool
     deriving Show Eq
 EntryR sql=entries
-    entryset EntrySetRId OnDeleteCascade 
-    account AccountRId OnDeleteCascade
+    entryset EntrySetRId  
+    account AccountRId 
     memo T.Text
     value Rational
     index Int
@@ -71,12 +78,20 @@ EntryR sql=entries
     cachedLink (Maybe Int)
     deriving Show Eq
 TagRelationR sql=tag_relations
-    entry EntryRId OnDeleteCascade
-    tag TagRId OnDeleteCascade
+    entry EntryRId 
+    tag TagRId
     deriving Show Eq
 |]
 
-data ConfigType = CTBudget | CTTransfer | CTHistory
+type DaySpan = (Day, Int)
+
+newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
+  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
+
+newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
+  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
+
+data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
   deriving (Eq, Show, Read, Enum, Ord)
 
 instance PersistFieldSql ConfigType where
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 5d96fb7..9872ae2 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -39,6 +39,7 @@ data DeleteTxs = DeleteTxs
   , dtEntries :: ![EntryRId]
   , dtTagRelations :: ![TagRelationRId]
   }
+  deriving (Show)
 
 type CDOps c d = CRUDOps [c] () () [d]
 
@@ -53,14 +54,15 @@ data ConfigState = ConfigState
   , csAccountMap :: !AccountMap
   , csCurrencyMap :: !CurrencyMap
   , csTagMap :: !TagMap
-  , csBudgetScope :: !DaySpan
-  , csHistoryScope :: !DaySpan
+  , csBudgetScope :: !BudgetSpan
+  , csHistoryScope :: !HistorySpan
   }
+  deriving (Show)
 
 data ExistingConfig = ExistingConfig
-  { ecAccounts :: !(HashSet Int)
-  , ecTags :: !(HashSet Int)
-  , ecCurrencies :: !(HashSet Int)
+  { ecAccounts :: !(Set AccountRId)
+  , ecTags :: !(Set TagRId)
+  , ecCurrencies :: !(Set CurrencyRId)
   }
 
 type AccountMap = M.Map AcntID (AccountRId, AcntType)
@@ -78,6 +80,7 @@ data CRUDOps c r u d = CRUDOps
   , coUpdate :: !u
   , coDelete :: !d
   }
+  deriving (Show)
 
 data DBState_ = DBState_
   { dbsCurrencyMap :: !CurrencyMap
@@ -198,8 +201,6 @@ data TxRecord = TxRecord
   }
   deriving (Show, Eq, Ord)
 
-type DaySpan = (Day, Natural)
-
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
 accountSign :: AcntType -> AcntSign
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index b3a8e54..7d18586 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -151,7 +151,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState csBudgetScope
+  globalSpan <- askDBState (unBSpan . csBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'

From cd89597b1f3b47ad551e812ce5f89397a2f9684c Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 15 Jul 2023 23:28:21 -0400
Subject: [PATCH 53/59] REF delete lots of dead code

---
 app/Main.hs              |  29 +----
 lib/Internal/Database.hs | 270 +++------------------------------------
 2 files changed, 16 insertions(+), 283 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 4304bc0..3845f45 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -231,36 +231,13 @@ runSync threads c bs hs = do
     -- the database, don't read it but record the commit so we can update it.
     toIns <-
       flip runReaderT state $ do
-        -- TODO for some mysterious reason using multithreading just for this
-        -- little bit slows the program down by several seconds
-        -- lift $ setNumCapabilities threads
-        -- (liftIO . print) =<< askDBState (M.keys . csAccountMap)
-        -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
-        -- lift $ setNumCapabilities 1
-        -- lift $ print $ length $ lefts hSs'
-        -- lift $ print $ length $ rights hSs'
         (CRUDOps hTs _ _ _) <- askDBState csHistTrans
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        -- lift $ print $ length $ lefts hTs'
         (CRUDOps bTs _ _ _) <- askDBState csBudgets
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
-        -- lift $ print $ length $ lefts bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
-    print $ length $ coCreate $ csBudgets state
-    print $ length $ coCreate $ csHistTrans state
-    print $ length $ coCreate $ csHistStmts state
-    print $ length $ coUpdate $ csBudgets state
-    print $ length $ coUpdate $ csHistTrans state
-    print $ length $ coUpdate $ csHistStmts state
-    print $ length $ coRead $ csBudgets state
-    print $ length $ coRead $ csHistTrans state
-    print $ length $ coRead $ csHistStmts state
-    print $ coDelete $ csBudgets state
-    print $ coDelete $ csHistTrans state
-    print $ coDelete $ csHistStmts state
-    -- print $ fmap hash $ coCreate $ csHistStmts state
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
@@ -288,8 +265,4 @@ readConfig :: MonadUnliftIO m => FilePath -> m Config
 readConfig = fmap unfix . readDhall
 
 readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
-readDhall confpath = do
-  -- tid <- myThreadId
-  -- liftIO $ print $ show tid
-  -- liftIO $ print confpath
-  liftIO $ Dhall.inputFile Dhall.auto confpath
+readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 507e09c..b41937f 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -4,7 +4,6 @@ module Internal.Database
   , nukeTables
   , updateHashes
   , updateDBState
-  -- , getDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -108,16 +107,6 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
--- data TxState = TxState
---   { tsBudget :: !(CRUDOps () () () ())
---   , tsHistTransfer :: !(CRUDOps () () () ())
---   , tsHistStatement :: !(CRUDOps () () () ())
---   }
-
--- readTxState :: (MonadFinance m, MonadUnliftIO m) -> [Budget] -> [History] -> m TxState
--- readTxState bs hs = do
---   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-
 readConfigState
   :: (MonadInsertError m, MonadSqlQuery m)
   => Config
@@ -285,23 +274,6 @@ readCurrentCommits = do
             CTHistoryTransfer -> (bs, y : ts, hs)
             CTHistoryStatement -> (bs, ts, y : hs)
 
--- hashConfig :: [Budget] -> [History] -> [Int]
--- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
---   where
---     (ms, ps) = partitionEithers $ fmap go hs
---     go (HistTransfer x) = Left x
---     go (HistStatement x) = Right x
-
--- setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
--- setDiff2 = setDiffWith2 (==)
-
--- -- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
--- -- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
-
--- -- setDiff as bs = (as \\ bs, bs \\ as)
--- setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
--- setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
-
 setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
 setDiffWith f = go [] []
   where
@@ -318,9 +290,6 @@ findDelete f xs = case break f xs of
   (ys, []) -> (Nothing, ys)
   (ys, z : zs) -> (Just z, ys ++ zs)
 
--- getDBHashes :: MonadSqlQuery m => m [Int]
--- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
-
 nukeDBHash :: MonadSqlQuery m => Int -> m ()
 nukeDBHash h = deleteE $ do
   c <- E.from E.table
@@ -329,43 +298,9 @@ nukeDBHash h = deleteE $ do
 nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
--- getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
--- getConfigHashes bs hs = do
---   let ch = hashConfig bs hs
---   dh <- getDBHashes
---   return $ setDiff2 dh ch
-
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
 
--- deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
--- deleteAccount e = deleteE $ do
---   c <- E.from $ E.table @AccountR
---   E.where_ (c ^. AccountRId ==. E.val k)
---   where
---     k = entityKey e
-
--- deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
--- deleteCurrency e = deleteE $ do
---   c <- E.from $ E.table @CurrencyR
---   E.where_ (c ^. CurrencyRId ==. E.val k)
---   where
---     k = entityKey e
-
--- deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
--- deleteTag e = deleteE $ do
---   c <- E.from $ E.table @TagR
---   E.where_ (c ^. TagRId ==. E.val k)
---   where
---     k = entityKey e
-
--- -- TODO slip-n-slide code...
--- insertFull
---   :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
---   => Entity r
---   -> m ()
--- insertFull (Entity k v) = insertKey k v
-
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap =
   M.fromList
@@ -418,31 +353,6 @@ paths2IDs =
     . L.sortOn fst
     . fmap (first (NE.reverse . acntPath2NonEmpty))
 
--- -- none of these errors should fire assuming that input is sorted and unique
--- trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
--- trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
---   where
---     trimAll _ [] = []
---     trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
---       (a, [], bs) -> reverse $ trim i a : bs
---       (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
---     matchPre i (y, ys, old) new = case (y !? i, new !? i) of
---       (Nothing, Just _) ->
---         case ys of
---           [] -> (new, [], trim i y : old)
---           _ -> err "unsorted input"
---       (Just _, Nothing) -> err "unsorted input"
---       (Nothing, Nothing) -> err "duplicated inputs"
---       (Just a, Just b)
---         | a == b -> (new, y : ys, old)
---         | otherwise ->
---             let next = case ys of
---                   [] -> [trim i y]
---                   _ -> trimAll (i + 1) (reverse $ y : ys)
---              in (new, [], reverse next ++ old)
---     trim i = NE.take (i + 1)
---     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
-
 -- none of these errors should fire assuming that input is sorted and unique
 trimNames :: [NonEmpty T.Text] -> [AcntID]
 trimNames = fmap (T.intercalate "_") . go []
@@ -460,31 +370,6 @@ trimNames = fmap (T.intercalate "_") . go []
 groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
 groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
 
--- groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, (Maybe a, [NonEmpty a]))]
--- groupNonEmpty = fmap (second (go <$>)) . groupWith NE.head
---   where
---     go xs = case NE.nonEmpty $ NE.tail xs of
---       (x :| [])
-
--- where
---   go xs@((key :| _) :| _) = (key, xs)
-
--- go (x :| xs) = (x, Just xs)
-
--- (!?) :: NE.NonEmpty a -> Int -> Maybe a
--- xs !? n
---   | n < 0 = Nothing
---   -- Definition adapted from GHC.List
---   | otherwise =
---       foldr
---         ( \x r k -> case k of
---             0 -> Just x
---             _ -> r (k - 1)
---         )
---         (const Nothing)
---         xs
---         n
-
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
 flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
   ((IncomeT,) <$> arIncome)
@@ -506,66 +391,9 @@ makeAcntMap =
 indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
 indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
--- getDBState
---   :: (MonadInsertError m, MonadSqlQuery m)
---   => Config
---   -> [Budget]
---   -> [History]
---   -> m (DBState, DBUpdates)
--- getDBState c bs hs = do
---   (del, new) <- getConfigHashes bs hs
---   combineError bi si $ \b s ->
---     ( DBState
---         { kmCurrency = currencyMap cs
---         , kmAccount = undefined
---         , kmBudgetInterval = b
---         , kmStatementInterval = s
---         , kmTag = tagMap ts
---         , kmNewCommits = new
---         }
---     , DBUpdates
---         { duOldCommits = del
---         , duNewTagIds = ts
---         , duNewAcntPaths = undefined
---         , duNewAcntIds = acnts
---         , duNewCurrencyIds = cs
---         }
---     )
---   where
---     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
---     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
---     (acnts, _) = indexAcntRoot $ accounts c
---     cs = currency2Record <$> currencies c
---     ts = toRecord <$> tags c
---     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
---     tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
-
 updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
 
--- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateTags DBUpdates {duNewTagIds} = do
---   tags' <- selectE $ E.from $ E.table @TagR
---   let (toIns, toDel) = setDiff2 duNewTagIds tags'
---   mapM_ deleteTag toDel
---   mapM_ insertFull toIns
-
--- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
---   acnts' <- dumpTbl
---   let (toIns, toDel) = setDiff2 duNewAcntIds acnts'
---   deleteWhere ([] :: [Filter AccountPathR])
---   mapM_ deleteAccount toDel
---   mapM_ insertFull toIns
---   mapM_ insert duNewAcntPaths
-
--- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateCurrencies DBUpdates {duNewCurrencyIds} = do
---   curs' <- selectE $ E.from $ E.table @CurrencyR
---   let (toIns, toDel) = setDiff2 duNewCurrencyIds curs'
---   mapM_ deleteCurrency toDel
---   mapM_ insertFull toIns
-
 updateCD
   :: ( MonadSqlQuery m
      , PersistRecordBackend a SqlBackend
@@ -597,70 +425,6 @@ updateDBState = do
   h <- asks csHistoryScope
   repsertE (E.toSqlKey 1) $ ConfigStateR h b
 
-deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
-deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
-
-repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
-repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
-
-selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
-selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
-
-deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
-deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
-
-insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
-
--- whenHash
---   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
---   => ConfigType
---   -> a
---   -> b
---   -> (CommitRId -> m b)
---   -> m b
--- whenHash t o def f = do
---   let h = hash o
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then f =<< insert (CommitR h t) else return def
-
--- whenHash0
---   :: (Hashable a, MonadFinance m)
---   => ConfigType
---   -> a
---   -> b
---   -> (CommitR -> m b)
---   -> m b
--- whenHash0 t o def f = do
---   let h = hash o
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then f (CommitR h t) else return def
-
--- eitherHash
---   :: (Hashable a, MonadFinance m)
---   => ConfigType
---   -> a
---   -> (CommitR -> m b)
---   -> (CommitR -> m c)
---   -> m (Either b c)
--- eitherHash t o f g = do
---   let h = hash o
---   let c = CommitR h t
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then Right <$> g c else Left <$> f c
-
--- whenHash_
---   :: (Hashable a, MonadFinance m)
---   => ConfigType
---   -> a
---   -> m b
---   -> m (Maybe (CommitR, b))
--- whenHash_ t o f = do
---   let h = hash o
---   let c = CommitR h t
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then Just . (c,) <$> f else return Nothing
-
 readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
@@ -883,17 +647,6 @@ zipPaired prec = go ([], [])
       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) =
   maybe
@@ -939,10 +692,6 @@ insertAll ebs = do
       ck <- insert 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, itxEntrySets, itxBudget, itxPriority} = do
   k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
@@ -956,10 +705,6 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
     go k i e = void $ insertEntry k i e
 
--- case itxCommit of
---   BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
---   _ -> return ()
-
 insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId
 insertEntry
   k
@@ -983,3 +728,18 @@ updateTx :: MonadSqlQuery m => UEBalanced -> m ()
 updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
   where
     v = toRational $ unStaticValue ueValue
+
+deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
+deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
+
+repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
+repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
+
+selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
+selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
+
+deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
+deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
+
+insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
+insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)

From 81f09d12807df88bdd65c5560d76b13242a1eff3 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 00:10:49 -0400
Subject: [PATCH 54/59] REF use newtypes for ids and commits

---
 app/Main.hs                    |  2 +-
 lib/Internal/Budget.hs         | 22 +++++++++++---------
 lib/Internal/Database.hs       | 37 ++++++++++++----------------------
 lib/Internal/History.hs        | 14 ++++++-------
 lib/Internal/Types/Database.hs |  6 ++++--
 lib/Internal/Types/Dhall.hs    | 12 +++++++----
 lib/Internal/Types/Main.hs     | 29 --------------------------
 lib/Internal/Utils.hs          | 20 +++++++++---------
 8 files changed, 55 insertions(+), 87 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 3845f45..89dee6f 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -203,7 +203,7 @@ runDumpAccountKeys c = do
   mapM_ (uncurry printPair) ks
   where
     printPair i p = do
-      liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
+      liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
     double x = (x, x)
 
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index feeb26c..5f6a9dc 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -37,7 +37,7 @@ readBudget
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
     where
-      c = CommitR (hash b) CTBudget
+      c = CommitR (CommitHash $ hash b) CTBudget
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
       pre_ = sortAllos bgtPretax
@@ -107,10 +107,12 @@ readIncome
         let gross = realFracToDecimal (cpPrec cp) incGross
         foldDays (allocate cp gross) start days
     where
-      incRes = isIncomeAcnt srcAcnt
+      srcAcnt' = AcntID srcAcnt
+      destAcnt' = AcntID destAcnt
+      incRes = isIncomeAcnt srcAcnt'
       nonIncRes =
         mapErrors isNotIncomeAcnt $
-          destAcnt
+          destAcnt'
             : (alloAcnt <$> incPretax)
             ++ (alloAcnt <$> incTaxes)
             ++ (alloAcnt <$> incPosttax)
@@ -136,8 +138,8 @@ readIncome
         let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-        let src = entry0 srcAcnt "gross income" srcTags
-        let dest = entry0 destAcnt "balance after deductions" destTags
+        let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
+        let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
         let allos = allo2Trans <$> (pre ++ tax ++ post)
         let primary =
               EntrySet
@@ -256,8 +258,8 @@ allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc}
   Entry
     { eValue = LinkDeferred (EntryFixed faValue)
     , eComment = faDesc
-    , eAcnt = taAcnt
-    , eTags = taTags
+    , eAcnt = AcntID taAcnt
+    , eTags = TagID <$> taTags
     }
 
 allocatePre
@@ -347,7 +349,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
     let es = entryPair stFrom stTo cur stDesc stRatio ()
     return $ if not sha then Nothing else Just es
   where
-    curRes = lookupCurrencyKey stCurrency
+    curRes = lookupCurrencyKey (CurID stCurrency)
     shaRes = liftExcept $ shadowMatches stMatch tx
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
@@ -369,13 +371,13 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
     getAcntTo = getAcnt esTo
     getAcnt f = eAcnt . hesPrimary . f
     memberMaybe x AcntSet {asList, asInclude} =
-      (if asInclude then id else not) $ x `elem` asList
+      (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
 
 --------------------------------------------------------------------------------
 -- random
 
 alloAcnt :: Allocation w v -> AcntID
-alloAcnt = taAcnt . alloTo
+alloAcnt = AcntID . taAcnt . alloTo
 
 type IntAllocations =
   ( [DaySpanAllocation PretaxValue]
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index b41937f..d5af3bf 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -2,7 +2,6 @@ module Internal.Database
   ( runDB
   , readConfigState
   , nukeTables
-  , updateHashes
   , updateDBState
   , tree2Records
   , flattenAcntRoot
@@ -179,7 +178,7 @@ makeTxCRUD
   :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
   => ExistingConfig
   -> [a]
-  -> [Int]
+  -> [CommitHash]
   -> Bool
   -> m
       ( CRUDOps
@@ -190,7 +189,7 @@ makeTxCRUD
       )
 makeTxCRUD existing newThings curThings scopeChanged = do
   let (toDelHashes, overlap, toIns) =
-        setDiffWith (\a b -> hash b == a) curThings newThings
+        setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
   -- Check the overlap for rows with accounts/tags/currencies that
   -- won't exist on the next update. Those with invalid IDs will be set aside
   -- to delete and reinsert (which may also fail) later
@@ -206,7 +205,7 @@ makeTxCRUD existing newThings curThings scopeChanged = do
   toDelAll <- readTxIds toDelAllHashes
   return $ CRUDOps toInsAll toRead toUpdate toDelAll
 
-readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
+readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
 readTxIds cs = do
   xs <- selectE $ do
     (commits :& txs :& ess :& es :& ts) <-
@@ -249,18 +248,18 @@ makeTagMap :: [Entity TagR] -> TagMap
 makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
 tag2Record :: Tag -> Entity TagR
-tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
 
 currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
+  Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
 
 readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
 readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
   rs <- E.from E.table
   return (rs ^. E.persistIdField)
 
-readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
+readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
 readCurrentCommits = do
   xs <- selectE $ do
     rs <- E.from E.table
@@ -290,14 +289,6 @@ findDelete f xs = case break f xs of
   (ys, []) -> (Nothing, ys)
   (ys, z : zs) -> (Just z, ys ++ zs)
 
-nukeDBHash :: MonadSqlQuery m => Int -> m ()
-nukeDBHash h = deleteE $ do
-  c <- E.from E.table
-  E.where_ (c ^. CommitRHash ==. E.val h)
-
-nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
-nukeDBHashes = mapM_ nukeDBHash
-
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
 
@@ -355,7 +346,7 @@ paths2IDs =
 
 -- none of these errors should fire assuming that input is sorted and unique
 trimNames :: [NonEmpty T.Text] -> [AcntID]
-trimNames = fmap (T.intercalate "_") . go []
+trimNames = fmap (AcntID . T.intercalate "_") . go []
   where
     go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
     go prev = concatMap (go' prev) . groupNonEmpty
@@ -391,9 +382,6 @@ makeAcntMap =
 indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
 indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
-updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
-updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
-
 updateCD
   :: ( MonadSqlQuery m
      , PersistRecordBackend a SqlBackend
@@ -425,7 +413,11 @@ updateDBState = do
   h <- asks csHistoryScope
   repsertE (E.toSqlKey 1) $ ConfigStateR h b
 
-readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
+readInvalidIds
+  :: MonadSqlQuery m
+  => ExistingConfig
+  -> [(CommitHash, a)]
+  -> m ([CommitHash], [(CommitHash, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
     (commits :& _ :& entrysets :& entries :& tags) <-
@@ -462,7 +454,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
-  => [Int]
+  => [CommitHash]
   -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
 readUpdates hashes = do
   xs <- selectE $ do
@@ -729,9 +721,6 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
   where
     v = toRational $ unStaticValue ueValue
 
-deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
-deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
-
 repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
 repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
 
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index c3d2970..4baf99b 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -44,7 +44,7 @@ readHistTransfer ht = do
   bounds <- askDBState (unHSpan . csHistoryScope)
   expandTransfer c historyName bounds ht
   where
-    c = CommitR (hash ht) CTHistoryTransfer
+    c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -59,7 +59,7 @@ readHistStmt root i = do
   bounds <- askDBState (unHSpan . csHistoryScope)
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
-    c = CommitR (hash i) CTHistoryStatement
+    c = CommitR (CommitHash $ hash i) CTHistoryStatement
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@@ -405,18 +405,18 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
   where
     go = realFracToDecimal prec
 
-resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
-resolveAcnt = resolveEntryField AcntField
+resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
+resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
 
 resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
 resolveCurrency m r c = do
-  i <- resolveEntryField CurField r c
-  case M.lookup i m of
+  i <- resolveEntryField CurField r (unCurID <$> c)
+  case M.lookup (CurID i) m of
     Just k -> return k
     -- TODO this should be its own error (I think)
     Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
 
-resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
+resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> InsertExcept T.Text
 resolveEntryField t TxRecord {trOther = o} s = case s of
   ConstT p -> return p
   LookupT f -> lookup_ f o
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 812363b..a6fbc2f 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -15,12 +15,11 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
--- TODO use newtypes for all the different numbers so they don't get mixed up
 share
   [mkPersist sqlSettings, mkMigrate "migrateAll"]
   [persistLowerCase|
 CommitR sql=commits
-    hash Int
+    hash CommitHash
     type ConfigType
     UniqueCommitHash hash
     deriving Show Eq Ord
@@ -85,6 +84,9 @@ TagRelationR sql=tag_relations
 
 type DaySpan = (Day, Int)
 
+newtype CommitHash = CommitHash {unCommitHash :: Int}
+  deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
+
 newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
   deriving newtype (Show, Eq, PersistField, PersistFieldSql)
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index a4b6ba4..1ea0c60 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -21,6 +21,7 @@ import qualified RIO.Map as M
 import qualified RIO.Text as T
 import Text.Regex.TDFA
 
+-- TODO find a way to conventiently make TaggedAcnt use my newtypes
 makeHaskellTypesWith
   (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
   [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@@ -231,7 +232,8 @@ deriving instance Hashable TaggedAcnt
 
 deriving instance Ord TaggedAcnt
 
-type CurID = T.Text
+newtype CurID = CurID {unCurID :: T.Text}
+  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
 
 data Income = Income
   { incGross :: Double
@@ -411,9 +413,11 @@ instance FromDhall a => FromDhall (Config_ a)
 -- dhall type overrides (since dhall can't import types with parameters...yet)
 
 -- TODO newtypes for these?
-type AcntID = T.Text
+newtype AcntID = AcntID {unAcntID :: T.Text}
+  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
 
-type TagID = T.Text
+newtype TagID = TagID {unTagID :: T.Text}
+  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
 
 data History
   = HistTransfer !PairedTransfer
@@ -465,7 +469,7 @@ data EntryTextGetter t
   | LookupT !T.Text
   | MapT !(FieldMap T.Text t)
   | Map2T !(FieldMap (T.Text, T.Text) t)
-  deriving (Eq, Generic, Hashable, Show, FromDhall)
+  deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
 
 type EntryCur = EntryTextGetter CurID
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 9872ae2..2e14ab1 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -82,35 +82,6 @@ data CRUDOps c r u d = CRUDOps
   }
   deriving (Show)
 
-data DBState_ = DBState_
-  { dbsCurrencyMap :: !CurrencyMap
-  , dbsAccountMap :: !AccountMap
-  , dbsTagMap :: !TagMap
-  , dbsBudgetInterval :: !DaySpan
-  , dbsHistoryInterval :: !DaySpan
-  , dbsNewCommits :: ![Int]
-  }
-  deriving (Show)
-
-data DBState = DBState
-  { kmCurrency :: !CurrencyMap
-  , kmAccount :: !AccountMap
-  , kmTag :: !TagMap
-  , kmBudgetInterval :: !DaySpan
-  , kmStatementInterval :: !DaySpan
-  , kmNewCommits :: ![Int]
-  }
-  deriving (Show)
-
-data DBUpdates = DBUpdates
-  { duOldCommits :: ![Int]
-  , duNewTagIds :: ![Entity TagR]
-  , duNewAcntPaths :: ![AccountPathR]
-  , duNewAcntIds :: ![Entity AccountR]
-  , duNewCurrencyIds :: ![Entity CurrencyR]
-  }
-  deriving (Show)
-
 data DBDeferred
   = DBEntryLinked Natural Double
   | DBEntryBalance Decimal
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 7d18586..ba62619 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -432,7 +432,7 @@ showError other = case other of
   (AccountError a ts) ->
     [ T.unwords
         [ "account type of key"
-        , singleQuote a
+        , singleQuote $ unAcntID a
         , "is not one of:"
         , ts_
         ]
@@ -496,7 +496,7 @@ showError other = case other of
         [ "No credit entry for index"
         , singleQuote $ tshow lngIndex
         , "for entry with account"
-        , singleQuote eAcnt
+        , singleQuote $ unAcntID eAcnt
         , "on"
         , tshow day
         ]
@@ -504,7 +504,7 @@ showError other = case other of
   (RoundError cur) ->
     [ T.unwords
         [ "Could not look up precision for currency"
-        , singleQuote cur
+        , singleQuote $ unCurID cur
         ]
     ]
 
@@ -637,20 +637,20 @@ lookupAccountType = fmap snd . lookupAccount
 lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
 lookupCurrency = lookupFinance CurField csCurrencyMap
 
-lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
+lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
 
-lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision
+lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
 lookupTag = lookupFinance TagField csTagMap
 
 lookupFinance
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadInsertError m, MonadFinance m, Ord k, Show k)
   => EntryIDType
-  -> (ConfigState -> M.Map T.Text a)
-  -> T.Text
+  -> (ConfigState -> M.Map k a)
+  -> k
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
 
@@ -1045,8 +1045,8 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
   EntrySet
     { esCurrency = curid
     , esTotalValue = totval
-    , esFrom = halfEntry fa fts val1
-    , esTo = halfEntry ta tts ()
+    , esFrom = halfEntry (AcntID fa) (TagID <$> fts) val1
+    , esTo = halfEntry (AcntID ta) (TagID <$> tts) ()
     }
   where
     halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0

From 642ebb472715773c5522323e3207c0d2f23b1dc7 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 00:20:01 -0400
Subject: [PATCH 55/59] REF use newtype for precision

---
 lib/Internal/Budget.hs         | 10 +++++-----
 lib/Internal/History.hs        |  4 ++--
 lib/Internal/Types/Database.hs |  5 ++++-
 lib/Internal/Types/Main.hs     |  2 --
 lib/Internal/Utils.hs          | 10 +++++++++-
 5 files changed, 20 insertions(+), 11 deletions(-)

diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 5f6a9dc..c962af3 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -104,7 +104,7 @@ readIncome
       (combineError incRes nonIncRes (,))
       (combineError cpRes dayRes (,))
       $ \_ (cp, days) -> do
-        let gross = realFracToDecimal (cpPrec cp) incGross
+        let gross = realFracToDecimal' (cpPrec cp) incGross
         foldDays (allocate cp gross) start days
     where
       srcAcnt' = AcntID srcAcnt
@@ -172,10 +172,10 @@ periodScaler pt prev cur = return scale
       Daily ds -> ds
     scale prec x = case pt of
       Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        realFracToDecimal prec (x / fromIntegral hpAnnualHours)
+        realFracToDecimal' prec (x / fromIntegral hpAnnualHours)
           * fromIntegral hpDailyHours
           * fromIntegral n
-      Daily _ -> realFracToDecimal prec (x * fromIntegral n / 365.25)
+      Daily _ -> realFracToDecimal' prec (x * fromIntegral n / 365.25)
 
 -- ASSUME start < end
 workingDays :: [Weekday] -> Day -> Day -> Natural
@@ -273,7 +273,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
       let v =
             if prePercent
               then gross *. (preValue / 100)
-              else realFracToDecimal precision preValue
+              else realFracToDecimal' precision preValue
        in (mapAdd_ preCategory v m, f {faValue = v})
 
 allocateTax
@@ -322,7 +322,7 @@ allocatePost prec aftertax = fmap (fmap go)
   where
     go PosttaxValue {postValue, postPercent}
       | postPercent = aftertax *. (postValue / 100)
-      | otherwise = realFracToDecimal prec postValue
+      | otherwise = realFracToDecimal' prec postValue
 
 --------------------------------------------------------------------------------
 -- shadow transfers
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 4baf99b..94e0341 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -306,7 +306,7 @@ toTx
         , txPrimary =
             Left $
               EntrySet
-                { esTotalValue = roundTo (cpPrec cur) trAmount *. tgScale
+                { esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
                 , esCurrency = cpID cur
                 , esFrom = f
                 , esTo = t
@@ -403,7 +403,7 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
   BalanceN x -> return $ EntryBalance $ go x
   PercentN x -> return $ EntryPercent x
   where
-    go = realFracToDecimal prec
+    go = realFracToDecimal' prec
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
 resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index a6fbc2f..7d18dcb 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -30,7 +30,7 @@ ConfigStateR sql=config_state
 CurrencyR sql=currencies
     symbol CurID
     fullname T.Text
-    precision Int
+    precision Precision
     UniqueCurrencySymbol symbol
     UniqueCurrencyFullname fullname
     deriving Show Eq Ord
@@ -82,6 +82,9 @@ TagRelationR sql=tag_relations
     deriving Show Eq
 |]
 
+newtype Precision = Precision {unPrecision :: Word8}
+  deriving newtype (Eq, Ord, Num, Show, PersistField, PersistFieldSql)
+
 type DaySpan = (Day, Int)
 
 newtype CommitHash = CommitHash {unCommitHash :: Int}
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 2e14ab1..4245ece 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -109,8 +109,6 @@ data CurrencyRound = CurrencyRound CurID Natural
 
 deriving instance Functor (UpdateEntry i)
 
-type Precision = Word8
-
 newtype LinkScale = LinkScale {unLinkScale :: Decimal}
   deriving newtype (Num, Show)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index ba62619..da50816 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -52,6 +52,8 @@ module Internal.Utils
   , entryPair
   , singleQuote
   , keyVals
+  , realFracToDecimal'
+  , roundToP
   )
 where
 
@@ -1016,7 +1018,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         } = do
         cp <- lookupCurrency transCurrency
         let v' = (-v)
-        let dec = realFracToDecimal (cpPrec cp) v'
+        let dec = realFracToDecimal' (cpPrec cp) v'
         let v'' = case t of
               TFixed -> EntryFixed dec
               TPercent -> EntryPercent v'
@@ -1071,3 +1073,9 @@ 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, [])
+
+realFracToDecimal' :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
+realFracToDecimal' p = realFracToDecimal (unPrecision p)
+
+roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
+roundToP p = roundTo (unPrecision p)

From 901882b79f0a0a742a48d52785bfb1542cdfdd23 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 00:39:03 -0400
Subject: [PATCH 56/59] REF use newtypes for budget and tx desc

---
 lib/Internal/Budget.hs         |  4 ++--
 lib/Internal/Database.hs       |  8 ++++----
 lib/Internal/History.hs        |  6 +++---
 lib/Internal/Types/Database.hs | 10 +++++++---
 lib/Internal/Types/Dhall.hs    |  5 ++++-
 lib/Internal/Types/Main.hs     | 14 +++++++-------
 lib/Internal/Utils.hs          | 14 +++++++-------
 7 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index c962af3..1da9539 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -78,7 +78,7 @@ sortAllo a@Allocation {alloAmts = as} = do
 readIncome
   :: (MonadInsertError m, MonadFinance m)
   => CommitR
-  -> T.Text
+  -> BudgetName
   -> IntAllocations
   -> DaySpan
   -> Income
@@ -154,7 +154,7 @@ readIncome
             , txDate = day
             , txPrimary = Left primary
             , txOther = []
-            , txDescr = ""
+            , txDescr = TxDesc ""
             , txBudget = name
             , txPriority = incPriority
             }
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index d5af3bf..2b4049b 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -298,7 +298,7 @@ currencyMap =
     . fmap
       ( \e ->
           ( currencyRSymbol $ entityVal e
-          , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e
+          , CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
           )
       )
 
@@ -517,7 +517,7 @@ readUpdates hashes = do
                   , utToRO = toRO
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
-                  , utTotalValue = realFracToDecimal prec' tot
+                  , utTotalValue = realFracToDecimal' prec' tot
                   , utBudget = E.unValue name
                   , utPriority = E.unValue pri
                   }
@@ -656,7 +656,7 @@ splitDeferredValue prec p = do
 readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
 readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
   (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
-  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal prec v
+  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal' prec v
   (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
   (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   _ -> throwError $ InsertException undefined
@@ -667,7 +667,7 @@ makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
 
 makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
-makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal prec $ entryRValue e)
+makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal' prec $ entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 94e0341..a7522dc 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -284,7 +284,7 @@ matches
       val = valMatches spVal $ toRational trAmount
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
-      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
+      desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
       convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
 
 toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
@@ -539,5 +539,5 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
       k <- readSign sign
       return (k, w)
 
-historyName :: T.Text
-historyName = "history"
+historyName :: BudgetName
+historyName = BudgetName "history"
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 7d18dcb..15709a9 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -7,6 +7,7 @@
 -- | Types corresponding to the database model
 module Internal.Types.Database where
 
+import Data.Csv (FromField)
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
 import Internal.Types.Dhall
@@ -56,8 +57,8 @@ AccountPathR sql=account_paths
 TransactionR sql=transactions
     commit CommitRId 
     date Day
-    description T.Text
-    budgetName T.Text
+    description TxDesc
+    budgetName BudgetName
     priority Int
     deriving Show Eq
 EntrySetR sql=entry_sets
@@ -82,8 +83,11 @@ TagRelationR sql=tag_relations
     deriving Show Eq
 |]
 
+newtype TxDesc = TxDesc {unTxDesc :: T.Text}
+  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
+
 newtype Precision = Precision {unPrecision :: Word8}
-  deriving newtype (Eq, Ord, Num, Show, PersistField, PersistFieldSql)
+  deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
 
 type DaySpan = (Day, Int)
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index 1ea0c60..1a72ea3 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -187,8 +187,11 @@ deriving instance Generic PairedTransfer
 
 deriving instance FromDhall PairedTransfer
 
+newtype BudgetName = BudgetName {unBudgetName :: T.Text}
+  deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
+
 data Budget = Budget
-  { bgtLabel :: Text
+  { bgtLabel :: BudgetName
   , bgtIncomes :: [Income]
   , bgtPretax :: [MultiAllocation PretaxValue]
   , bgtTax :: [MultiAllocation TaxValue]
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 4245ece..13764cf 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -93,7 +93,7 @@ data ReadEntry = ReadEntry
   , reValue :: !Decimal
   , reDate :: !Day
   , rePriority :: !Int
-  , reBudget :: !T.Text
+  , reBudget :: !BudgetName
   }
   deriving (Show)
 
@@ -137,7 +137,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !t
-  , utBudget :: !T.Text
+  , utBudget :: !BudgetName
   , utPriority :: !Int
   }
   deriving (Show)
@@ -164,7 +164,7 @@ askDBState = asks
 data TxRecord = TxRecord
   { trDate :: !Day
   , trAmount :: !Decimal
-  , trDesc :: !T.Text
+  , trDesc :: !TxDesc
   , trOther :: !(M.Map T.Text T.Text)
   , trFile :: !FilePath
   }
@@ -209,13 +209,13 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
 
 data Tx k = Tx
-  { txDescr :: !T.Text
+  { txDescr :: !TxDesc
   , txDate :: !Day
   , txPriority :: !Int
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
-  , txBudget :: !T.Text
+  , txBudget :: !BudgetName
   }
   deriving (Generic, Show)
 
@@ -231,12 +231,12 @@ data InsertEntrySet = InsertEntrySet
   }
 
 data InsertTx = InsertTx
-  { itxDescr :: !T.Text
+  { itxDescr :: !TxDesc
   , itxDate :: !Day
   , itxPriority :: !Int
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
   , itxCommit :: !CommitR
-  , itxBudget :: !T.Text
+  , itxBudget :: !BudgetName
   }
   deriving (Generic)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index da50816..5f43653 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -520,7 +520,7 @@ tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       [ ("path", T.pack f)
       , ("date", T.pack $ iso8601Show d)
       , ("value", tshow v)
-      , ("description", doubleQuote e)
+      , ("description", doubleQuote $ unTxDesc e)
       ]
 
 showMatch :: MatchRe -> T.Text
@@ -700,7 +700,7 @@ binDate (ToUpdate u) = either go go u
   where
     go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
 
-type BCKey = (CurrencyRId, Text)
+type BCKey = (CurrencyRId, BudgetName)
 
 type ABCKey = (AccountRId, BCKey)
 
@@ -835,7 +835,7 @@ updateUnknown k e = do
 
 balancePrimaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => T.Text
+  => BudgetName
   -> PrimaryEntrySet
   -> StateT EntryBals m InsertEntrySet
 balancePrimaryEntrySet
@@ -860,7 +860,7 @@ balancePrimaryEntrySet
 
 balanceSecondaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => T.Text
+  => BudgetName
   -> SecondayEntrySet
   -> StateT EntryBals m InsertEntrySet
 balanceSecondaryEntrySet
@@ -992,7 +992,7 @@ findBalance k e = do
 expandTransfers
   :: (MonadInsertError m, MonadFinance m)
   => CommitR
-  -> T.Text
+  -> BudgetName
   -> DaySpan
   -> [PairedTransfer]
   -> m [Tx CommitR]
@@ -1001,7 +1001,7 @@ expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name
 expandTransfer
   :: (MonadInsertError m, MonadFinance m)
   => CommitR
-  -> T.Text
+  -> BudgetName
   -> DaySpan
   -> PairedTransfer
   -> m [Tx CommitR]
@@ -1030,7 +1030,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
               , txDate = day
               , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
               , txOther = []
-              , txDescr = desc
+              , txDescr = TxDesc desc
               , txBudget = name
               , txPriority = fromIntegral pri
               }

From ad5e4a07486c9e4edc95cf3f1af419fa3c9fa282 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 12:15:39 -0400
Subject: [PATCH 57/59] REF use newtype for indices

---
 lib/Internal/Database.hs       |  4 ++--
 lib/Internal/History.hs        | 27 ---------------------------
 lib/Internal/Types/Database.hs | 12 +++++++++---
 lib/Internal/Types/Main.hs     |  9 +--------
 lib/Internal/Utils.hs          | 15 +++------------
 5 files changed, 15 insertions(+), 52 deletions(-)

diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 2b4049b..f166c24 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -620,7 +620,7 @@ splitTo prec from0 fromUnk (t0 :| ts) = do
 zipPaired
   :: Precision
   -> [UEUnk]
-  -> [(Int, NonEmpty (EntryRId, EntryR))]
+  -> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
   -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
 zipPaired prec = go ([], [])
   where
@@ -697,7 +697,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
     go k i e = void $ insertEntry k i e
 
-insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId
+insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
 insertEntry
   k
   i
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index a7522dc..877e973 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -485,33 +485,6 @@ matchGroupsMaybe q re = case regexec re q of
   -- this should never fail as regexec always returns Right
   Left _ -> []
 
--- parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
--- parseRational (pat, re) s = case matchGroupsMaybe s re of
---   [sign, x, ""] -> uncurry (*) <$> readWhole sign x
---   [sign, x, y] -> do
---     d <- readT "decimal" y
---     let p = 10 ^ T.length y
---     (k, w) <- readWhole sign x
---     return $ k * (w + d % p)
---   _ -> msg "malformed decimal"
---   where
---     readT what t = case readMaybe $ T.unpack t of
---       Just d -> return $ fromInteger d
---       _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
---     msg :: MonadFail m => T.Text -> m a
---     msg m =
---       fail $
---         T.unpack $
---           T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
---     readSign x
---       | x == "-" = return (-1)
---       | x == "+" || x == "" = return 1
---       | otherwise = msg $ T.append "invalid sign: " x
---     readWhole sign x = do
---       w <- readT "whole number" x
---       k <- readSign sign
---       return (k, w)
-
 parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
 parseDecimal (pat, re) s = case matchGroupsMaybe s re of
   [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 15709a9..f85efbc 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -64,7 +64,7 @@ TransactionR sql=transactions
 EntrySetR sql=entry_sets
     transaction TransactionRId 
     currency CurrencyRId 
-    index Int
+    index EntrySetIndex
     rebalance Bool
     deriving Show Eq
 EntryR sql=entries
@@ -72,10 +72,10 @@ EntryR sql=entries
     account AccountRId 
     memo T.Text
     value Rational
-    index Int
+    index EntryIndex
     cachedValue (Maybe Rational)
     cachedType (Maybe TransferType)
-    cachedLink (Maybe Int)
+    cachedLink (Maybe EntryIndex)
     deriving Show Eq
 TagRelationR sql=tag_relations
     entry EntryRId 
@@ -83,6 +83,12 @@ TagRelationR sql=tag_relations
     deriving Show Eq
 |]
 
+newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
+  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
+
+newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
+  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
+
 newtype TxDesc = TxDesc {unTxDesc :: T.Text}
   deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 13764cf..1b12fbb 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -26,13 +26,6 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types
 
-data ConfigHashes = ConfigHashes
-  { chIncome :: ![Int]
-  , chExpense :: ![Int]
-  , chManual :: ![Int]
-  , chImport :: ![Int]
-  }
-
 data DeleteTxs = DeleteTxs
   { dtTxs :: ![TransactionRId]
   , dtEntrySets :: ![EntrySetRId]
@@ -101,7 +94,7 @@ data UpdateEntry i v = UpdateEntry
   { ueID :: !i
   , ueAcnt :: !AccountRId
   , ueValue :: !v
-  , ueIndex :: !Int
+  , ueIndex :: !EntryIndex
   }
   deriving (Show)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 5f43653..905f0b8 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -4,7 +4,6 @@ module Internal.Utils
   , askDays
   , fromWeekday
   , inDaySpan
-  , fmtRational
   , fromGregorian'
   , resolveDaySpan
   , resolveDaySpan_
@@ -306,6 +305,9 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
 dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
+--------------------------------------------------------------------------------
+-- error flow control
+
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
 
@@ -409,17 +411,6 @@ lookupErr what k m = case M.lookup k m of
   Just x -> return x
   _ -> throwError $ InsertException [LookupError what $ tshow k]
 
-fmtRational :: Natural -> Rational -> T.Text
-fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
-  where
-    s = if x >= 0 then "" else "-"
-    x'@(n :% d) = abs x
-    p = 10 ^ precision
-    n' = div n d
-    d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
-    txt = T.pack . show
-    pad i c z = T.append (T.replicate (i - T.length z) c) z
-
 --------------------------------------------------------------------------------
 -- error display
 

From cafc0668818363f073f3c8373e8d63c2a391a58f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 12:51:39 -0400
Subject: [PATCH 58/59] REF clean up useless types

---
 app/Main.hs                | 14 ++++----
 lib/Internal/Budget.hs     | 12 ++++---
 lib/Internal/Database.hs   | 14 ++++----
 lib/Internal/History.hs    | 12 +++----
 lib/Internal/Types/Main.hs | 43 +++++++------------------
 lib/Internal/Utils.hs      | 65 +++++++++++---------------------------
 6 files changed, 56 insertions(+), 104 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 89dee6f..2e55f87 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -231,11 +231,11 @@ runSync threads c bs hs = do
     -- the database, don't read it but record the commit so we can update it.
     toIns <-
       flip runReaderT state $ do
-        (CRUDOps hSs _ _ _) <- askDBState csHistStmts
+        (CRUDOps hSs _ _ _) <- asks csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
-        (CRUDOps hTs _ _ _) <- askDBState csHistTrans
+        (CRUDOps hTs _ _ _) <- asks csHistTrans
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        (CRUDOps bTs _ _ _) <- askDBState csBudgets
+        (CRUDOps bTs _ _ _) <- asks csBudgets
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
 
@@ -244,9 +244,9 @@ runSync threads c bs hs = do
       -- NOTE this must come first (unless we defer foreign keys)
       updateDBState
       res <- runExceptT $ do
-        (CRUDOps _ bRs bUs _) <- askDBState csBudgets
-        (CRUDOps _ tRs tUs _) <- askDBState csHistTrans
-        (CRUDOps _ sRs sUs _) <- askDBState csHistStmts
+        (CRUDOps _ bRs bUs _) <- asks csBudgets
+        (CRUDOps _ tRs tUs _) <- asks csHistTrans
+        (CRUDOps _ sRs sUs _) <- asks csHistStmts
         let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
         insertAll ebs
       -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
@@ -259,8 +259,6 @@ runSync threads c bs hs = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
       exitFailure
 
--- showBalances
-
 readConfig :: MonadUnliftIO m => FilePath -> m Config
 readConfig = fmap unfix . readDhall
 
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 1da9539..0ea61d2 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -49,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState (unBSpan . csBudgetScope)
+        globalSpan <- asks (unBSpan . csBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -253,20 +253,22 @@ selectAllos day Allocation {alloAmts, alloTo} =
         , faDesc = amtDesc
         }
 
-allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
+allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
 allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
   Entry
-    { eValue = LinkDeferred (EntryFixed faValue)
+    { eValue = LinkValue (EntryFixed faValue)
     , eComment = faDesc
     , eAcnt = AcntID taAcnt
     , eTags = TagID <$> taTags
     }
 
+type PreDeductions = M.Map T.Text Decimal
+
 allocatePre
   :: Precision
   -> Decimal
   -> [FlatAllocation PretaxValue]
-  -> (M.Map T.Text Decimal, [FlatAllocation Decimal])
+  -> (PreDeductions, [FlatAllocation Decimal])
 allocatePre precision gross = L.mapAccumR go M.empty
   where
     go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
@@ -279,7 +281,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
 allocateTax
   :: Precision
   -> Decimal
-  -> M.Map T.Text Decimal
+  -> PreDeductions
   -> PeriodScaler
   -> [FlatAllocation TaxValue]
   -> [FlatAllocation Decimal]
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index f166c24..5401d55 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -674,7 +674,7 @@ makeUnkUE k e = makeUE k e ()
 
 insertAll
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin]
+  => [EntryCRU]
   -> m ()
 insertAll ebs = do
   (toUpdate, toInsert) <- balanceTxs ebs
@@ -692,7 +692,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
       let fs = NE.toList iesFromEntries
       let ts = NE.toList iesToEntries
-      let rebalance = any (isJust . ieDeferred) (fs ++ ts)
+      let rebalance = any (isJust . ieCached) (fs ++ ts)
       esk <- insert $ EntrySetR tk iesCurrency i rebalance
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
     go k i e = void $ insertEntry k i e
@@ -703,17 +703,17 @@ insertEntry
   i
   InsertEntry
     { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
-    , ieDeferred
+    , ieCached
     } =
     do
       ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
       mapM_ (insert_ . TagRelationR ek) eTags
       return ek
     where
-      (cval, ctype, deflink) = case ieDeferred of
-        (Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
-        (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
-        (Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
+      (cval, ctype, deflink) = case ieCached of
+        (Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
+        (Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
+        (Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
         Nothing -> (Nothing, Just TFixed, Nothing)
 
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index 877e973..fa234ce 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -41,7 +41,7 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- askDBState (unHSpan . csHistoryScope)
+  bounds <- asks (unHSpan . csHistoryScope)
   expandTransfer c historyName bounds ht
   where
     c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
@@ -56,7 +56,7 @@ readHistStmt
   -> m [Tx CommitR]
 readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState (unHSpan . csHistoryScope)
+  bounds <- asks (unHSpan . csHistoryScope)
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
     c = CommitR (CommitHash $ hash i) CTHistoryStatement
@@ -317,7 +317,7 @@ toTx
         }
     where
       curRes = do
-        m <- askDBState csCurrencyMap
+        m <- asks csCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -331,7 +331,7 @@ resolveSubGetter
   -> TxSubGetter
   -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- askDBState csCurrencyMap
+  m <- asks csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@@ -391,9 +391,9 @@ resolveEntry f prec r s@Entry {eAcnt, eValue} =
 resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
 resolveFromValue = resolveValue
 
-resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
+resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
 resolveToValue _ _ (Linked l) = return $ LinkIndex l
-resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
+resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
 
 resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
 resolveValue prec TxRecord {trOther, trAmount} s = case s of
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 1b12fbb..476c955 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -75,10 +75,10 @@ data CRUDOps c r u d = CRUDOps
   }
   deriving (Show)
 
-data DBDeferred
-  = DBEntryLinked Natural Double
-  | DBEntryBalance Decimal
-  | DBEntryPercent Double
+data CachedEntry
+  = CachedLink EntryIndex LinkScale
+  | CachedBalance Decimal
+  | CachedPercent Double
 
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
@@ -98,12 +98,10 @@ data UpdateEntry i v = UpdateEntry
   }
   deriving (Show)
 
-data CurrencyRound = CurrencyRound CurID Natural
-
 deriving instance Functor (UpdateEntry i)
 
-newtype LinkScale = LinkScale {unLinkScale :: Decimal}
-  deriving newtype (Num, Show)
+newtype LinkScale = LinkScale {unLinkScale :: Double}
+  deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
 
 newtype StaticValue = StaticValue {unStaticValue :: Decimal}
   deriving newtype (Num, Show)
@@ -139,18 +137,13 @@ type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
 
 type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
 
-data EntryBin
+data EntryCRU
   = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
   | ToRead ReadEntry
   | ToInsert (Tx CommitR)
 
-type TreeR = Tree ([T.Text], AccountRId)
-
 type MonadFinance = MonadReader ConfigState
 
-askDBState :: MonadFinance m => (ConfigState -> a) -> m a
-askDBState = asks
-
 -------------------------------------------------------------------------------
 -- misc
 
@@ -190,13 +183,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
 
 type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
 
-type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
+type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
 
-type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
+type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
 
 type TransferEntrySet = SecondayEntrySet
 
-type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
+type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
 
 data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
@@ -213,7 +206,7 @@ data Tx k = Tx
   deriving (Generic, Show)
 
 data InsertEntry = InsertEntry
-  { ieDeferred :: !(Maybe DBDeferred)
+  { ieCached :: !(Maybe CachedEntry)
   , ieEntry :: !(Entry AccountRId Decimal TagRId)
   }
 
@@ -233,18 +226,13 @@ data InsertTx = InsertTx
   }
   deriving (Generic)
 
-data Deferred a = Deferred Bool a
-  deriving (Show, Functor, Foldable, Traversable)
-
 data EntryValue_ a = EntryValue_ TransferType a
   deriving (Show, Functor, Foldable, Traversable)
 
 data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
   deriving (Show, Eq, Ord)
 
-data LinkDeferred
-  = LinkDeferred EntryValue
-  | LinkIndex LinkedNumGetter
+data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
   deriving (Show)
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
@@ -302,13 +290,6 @@ type InsertExceptT = ExceptT InsertException
 
 type InsertExcept = InsertExceptT Identity
 
-data XGregorian = XGregorian
-  { xgYear :: !Int
-  , xgMonth :: !Int
-  , xgDay :: !Int
-  , xgDayOfWeek :: !Int
-  }
-
 type MatchRe = StatementParser (T.Text, Regex)
 
 type TxOptsRe = TxOpts (T.Text, Regex)
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 905f0b8..6931fe9 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -30,9 +30,7 @@ module Internal.Utils
   , showError
   , tshow
   , lookupErr
-  , gregorians
   , uncurry3
-  , xGregToDay
   , dateMatches
   , valMatches
   , lookupAccount
@@ -152,7 +150,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState (unBSpan . csBudgetScope)
+  globalSpan <- asks (unBSpan . csBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -174,33 +172,6 @@ fromWeekday Fri = Friday
 fromWeekday Sat = Saturday
 fromWeekday Sun = Sunday
 
--- | find the next date
--- this is meant to go in a very tight loop and be very fast (hence no
--- complex date functions, most of which heavily use 'mod' and friends)
-nextXGreg :: XGregorian -> XGregorian
-nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
-  | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
-  | (m == 2 && (not leap && d == 28 || (leap && d == 29)))
-      || (m `elem` [4, 6, 9, 11] && d == 30)
-      || (d == 31) =
-      XGregorian y (m + 1) 1 w_
-  | otherwise = XGregorian y m (d + 1) w_
-  where
-    -- don't use DayOfWeek from Data.Time since this uses mod (which uses a
-    -- division opcode) and thus will be slower than just checking for equality
-    -- and adding
-    w_ = if w == 6 then 0 else w + 1
-    leap = isLeapYear $ fromIntegral y
-
-gregorians :: Day -> [XGregorian]
-gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w
-  where
-    (y, m, d) = toGregorian x
-    w = fromEnum $ dayOfWeek x
-
-xGregToDay :: XGregorian -> Day
-xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
-
 gregTup :: Gregorian -> (Integer, Int, Int)
 gregTup Gregorian {gYear, gMonth, gDay} =
   ( fromIntegral gYear
@@ -645,11 +616,11 @@ lookupFinance
   -> (ConfigState -> M.Map k a)
   -> k
   -> m a
-lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
+lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin]
+  => [EntryCRU]
   -> m ([UEBalanced], [InsertTx])
 balanceTxs ebs =
   first concat . partitionEithers . catMaybes
@@ -684,7 +655,7 @@ balanceTxs ebs =
             (balancePrimaryEntrySet txBudget . fromShadow tot)
         fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
-binDate :: EntryBin -> (Day, Int)
+binDate :: EntryCRU -> (Day, Int)
 binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
 binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
 binDate (ToUpdate u) = either go go u
@@ -768,7 +739,7 @@ rebalanceDebit k ro linked = do
       return (v, e0' : es')
 
 unlink :: Decimal -> UELink -> UEBalanced
-unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
+unlink v e = e {ueValue = StaticValue $ (-v) *. unLinkScale (ueValue e)}
 
 rebalanceCredit
   :: BCKey
@@ -880,7 +851,7 @@ balanceFinal
   -> Decimal
   -> NonEmpty InsertEntry
   -> Entry AccountRId () TagRId
-  -> [Entry AccountRId LinkDeferred TagRId]
+  -> [Entry AccountRId EntryLink TagRId]
   -> StateT EntryBals m InsertEntrySet
 balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
@@ -895,7 +866,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
 
 balanceTotalEntrySet
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Decimal
   -> Entry AccountRId () TagRId
@@ -909,7 +880,7 @@ balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
   let e' =
         InsertEntry
           { ieEntry = e {eValue = e0val, eAcnt = acntID}
-          , ieDeferred = Nothing
+          , ieCached = Nothing
           }
   return $ e' :| es'
   where
@@ -922,42 +893,42 @@ balanceLinked
   :: MonadInsertError m
   => Vector Decimal
   -> ABCKey
-  -> LinkDeferred
-  -> StateT EntryBals m (Decimal, Maybe DBDeferred)
+  -> EntryLink
+  -> StateT EntryBals m (Decimal, Maybe CachedEntry)
 balanceLinked from k 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 $ DBEntryLinked lngIndex lngScale)
+      Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale 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 k d
+  (LinkValue d) -> liftInnerS $ balanceDeferred k d
   where
     go s = negate . (*. s)
 
-balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
+balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe CachedEntry)
 balanceDeferred k e = do
   newval <- findBalance k e
   let d = case e of
         EntryFixed _ -> Nothing
-        EntryBalance v -> Just $ DBEntryBalance v
-        EntryPercent v -> Just $ DBEntryPercent v
+        EntryBalance v -> Just $ CachedBalance v
+        EntryPercent v -> Just $ CachedPercent v
   return (newval, d)
 
 balanceEntry
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Entry AccountRId v TagRId
   -> StateT EntryBals m InsertEntry
 balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
-  (newVal, deferred) <- f (acntID, k) eValue
+  (newVal, cached) <- f (acntID, k) eValue
   modify (mapAdd_ (acntID, k) newVal)
   return $
     InsertEntry
       { ieEntry = e {eValue = newVal, eAcnt = acntID}
-      , ieDeferred = deferred
+      , ieCached = cached
       }
 
 resolveAcntAndTags

From 2e0b5913126d97d1f39ee5993a1bd3f12fc1e1e6 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 19:55:33 -0400
Subject: [PATCH 59/59] ADD errors for everything that needs them (ish)

---
 app/Main.hs                |   2 +-
 lib/Internal/Budget.hs     |  38 +++----
 lib/Internal/Database.hs   |  54 +++++-----
 lib/Internal/History.hs    |  77 +++++++--------
 lib/Internal/Types/Main.hs |  56 ++++++-----
 lib/Internal/Utils.hs      | 197 +++++++++++++++++++------------------
 6 files changed, 223 insertions(+), 201 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 2e55f87..878fc5d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -255,7 +255,7 @@ runSync threads c bs hs = do
       rerunnableIO $ fromEither res
   where
     root = takeDirectory c
-    err (InsertException es) = do
+    err (AppException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
       exitFailure
 
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index 0ea61d2..682dae7 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -13,7 +13,7 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
-readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR]
+readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
 readBudget
   b@Budget
     { bgtLabel
@@ -56,7 +56,7 @@ readBudget
             localSpan <- liftExcept $ resolveDaySpan bi
             return $ intersectDaySpan globalSpan localSpan
 
-sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
+sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
   bs <- foldSpan [] $ L.sortOn amtWhen as
   return $ a {alloAmts = reverse bs}
@@ -76,7 +76,7 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- iteration which is a total waste, but the fix requires turning this
 -- loop into a fold which I don't feel like doing now :(
 readIncome
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => CommitR
   -> BudgetName
   -> IntAllocations
@@ -104,7 +104,7 @@ readIncome
       (combineError incRes nonIncRes (,))
       (combineError cpRes dayRes (,))
       $ \_ (cp, days) -> do
-        let gross = realFracToDecimal' (cpPrec cp) incGross
+        let gross = realFracToDecimalP (cpPrec cp) incGross
         foldDays (allocate cp gross) start days
     where
       srcAcnt' = AcntID srcAcnt
@@ -163,7 +163,7 @@ periodScaler
   :: PeriodType
   -> Day
   -> Day
-  -> InsertExcept PeriodScaler
+  -> AppExcept PeriodScaler
 periodScaler pt prev cur = return scale
   where
     n = workingDays wds prev cur
@@ -172,10 +172,10 @@ periodScaler pt prev cur = return scale
       Daily ds -> ds
     scale prec x = case pt of
       Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        realFracToDecimal' prec (x / fromIntegral hpAnnualHours)
+        realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
           * fromIntegral hpDailyHours
           * fromIntegral n
-      Daily _ -> realFracToDecimal' prec (x * fromIntegral n / 365.25)
+      Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
 
 -- ASSUME start < end
 workingDays :: [Weekday] -> Day -> Day -> Natural
@@ -191,7 +191,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
 
 -- ASSUME days is a sorted list
 foldDays
-  :: MonadInsertError m
+  :: MonadAppError m
   => (Day -> Day -> m a)
   -> Day
   -> [Day]
@@ -201,27 +201,27 @@ foldDays f start days = case NE.nonEmpty days of
   Just ds
     | any (start >) ds ->
         throwError $
-          InsertException [PeriodError start $ minimum ds]
+          AppException [PeriodError start $ minimum ds]
     | otherwise ->
         combineErrors $
           snd $
             L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
 
-isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
+isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
 isIncomeAcnt = checkAcntType IncomeT
 
-isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
+isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
 isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
 
 checkAcntType
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => AcntType
   -> AcntID
   -> m ()
 checkAcntType t = checkAcntTypes (t :| [])
 
 checkAcntTypes
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => NE.NonEmpty AcntType
   -> AcntID
   -> m ()
@@ -229,7 +229,7 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
   where
     go t
       | t `L.elem` ts = return i
-      | otherwise = throwError $ InsertException [AccountError i ts]
+      | otherwise = throwError $ AppException [AccountTypeError i ts]
 
 flattenAllo :: SingleAllocation v -> [FlatAllocation v]
 flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
@@ -275,7 +275,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
       let v =
             if prePercent
               then gross *. (preValue / 100)
-              else realFracToDecimal' precision preValue
+              else realFracToDecimalP precision preValue
        in (mapAdd_ preCategory v m, f {faValue = v})
 
 allocateTax
@@ -324,14 +324,14 @@ allocatePost prec aftertax = fmap (fmap go)
   where
     go PosttaxValue {postValue, postPercent}
       | postPercent = aftertax *. (postValue / 100)
-      | otherwise = realFracToDecimal' prec postValue
+      | otherwise = realFracToDecimalP prec postValue
 
 --------------------------------------------------------------------------------
 -- shadow transfers
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => [ShadowTransfer]
   -> [Tx CommitR]
   -> m [Tx CommitR]
@@ -342,7 +342,7 @@ addShadowTransfers ms = mapErrors go
       return $ tx {txOther = Right <$> es}
 
 fromShadow
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => Tx CommitR
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
@@ -354,7 +354,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
     curRes = lookupCurrencyKey (CurID stCurrency)
     shaRes = liftExcept $ shadowMatches stMatch tx
 
-shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
+shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept 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
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 5401d55..bb3d737 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -107,7 +107,7 @@ nukeTables = do
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
 readConfigState
-  :: (MonadInsertError m, MonadSqlQuery m)
+  :: (MonadAppError m, MonadSqlQuery m)
   => Config
   -> [Budget]
   -> [History]
@@ -160,22 +160,23 @@ readConfigState c bs hs = do
     resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
 
 readScopeChanged
-  :: (MonadInsertError m, MonadSqlQuery m)
+  :: (MonadAppError m, MonadSqlQuery m)
   => Bool
   -> BudgetSpan
   -> HistorySpan
   -> m (Bool, Bool)
 readScopeChanged dbempty bscope hscope = do
   rs <- dumpTbl
+  -- TODO these errors should only fire when someone messed with the DB
   case rs of
-    [] -> if dbempty then return (True, True) else throwError undefined
+    [] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
     [r] -> do
       let (ConfigStateR h b) = E.entityVal r
       return (bscope /= b, hscope /= h)
-    _ -> throwError undefined
+    _ -> throwAppError $ DBError DBMultiScope
 
 makeTxCRUD
-  :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
+  :: (MonadAppError m, MonadSqlQuery m, Hashable a)
   => ExistingConfig
   -> [a]
   -> [CommitHash]
@@ -354,9 +355,10 @@ trimNames = fmap (AcntID . T.intercalate "_") . go []
       (_ :| []) -> [key : prev]
       ([] :| xs) ->
         let next = key : prev
-            other = go next $ fmap (fromMaybe undefined . NE.nonEmpty) xs
+            other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
          in next : other
-      (x :| xs) -> go (key : prev) $ fmap (fromMaybe undefined . NE.nonEmpty) (x : xs)
+      (x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
+    err = error "account path list either not sorted or contains duplicates"
 
 groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
 groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
@@ -453,7 +455,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
         . groupKey id
 
 readUpdates
-  :: (MonadInsertError m, MonadSqlQuery m)
+  :: (MonadAppError m, MonadSqlQuery m)
   => [CommitHash]
   -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
 readUpdates hashes = do
@@ -517,7 +519,7 @@ readUpdates hashes = do
                   , utToRO = toRO
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
-                  , utTotalValue = realFracToDecimal' prec' tot
+                  , utTotalValue = realFracToDecimalP prec' tot
                   , utBudget = E.unValue name
                   , utPriority = E.unValue pri
                   }
@@ -536,7 +538,8 @@ readUpdates hashes = do
                   , utBudget = E.unValue name
                   , utPriority = E.unValue pri
                   }
-        _ -> throwError undefined
+        -- TODO this error is lame
+        _ -> throwAppError $ DBError $ DBUpdateUnbalanced
     makeRE ((_, day, name, pri, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
@@ -551,7 +554,7 @@ readUpdates hashes = do
 splitFrom
   :: Precision
   -> NonEmpty (EntryRId, EntryR)
-  -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
+  -> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
 splitFrom prec (f0 :| fs) = do
   -- ASSUME entries are sorted by index
   -- TODO combine errors here
@@ -567,7 +570,7 @@ splitTo
   -> Either UEBlank (Either UE_RO UEUnk)
   -> [UEUnk]
   -> NonEmpty (EntryRId, EntryR)
-  -> InsertExcept
+  -> AppExcept
       ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
       , [(UEUnk, [UELink])]
       , UEBlank
@@ -621,7 +624,7 @@ zipPaired
   :: Precision
   -> [UEUnk]
   -> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
-  -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
+  -> AppExcept ([(UEUnk, [UELink])], [UE_RO])
 zipPaired prec = go ([], [])
   where
     nolinks = ((,[]) <$>)
@@ -639,41 +642,46 @@ zipPaired prec = go ([], [])
       let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
       go (f acc') fs' ts
 
-makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
+makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
 makeLinkUnk (k, e) =
+  -- TODO error should state that scale must be present for a link in the db
   maybe
-    (throwError $ InsertException undefined)
+    (throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
     (return . makeUE k e . LinkScale)
     $ fromRational <$> entryRCachedValue e
 
-splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue prec p = do
+splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
+splitDeferredValue prec p@(k, _) = do
   res <- readDeferredValue prec p
   case res of
-    Left _ -> throwError $ InsertException undefined
+    Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
     Right x -> return x
 
-readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
+readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
 readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
   (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
-  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal' prec v
+  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
   (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
   (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
-  _ -> throwError $ InsertException undefined
+  (Just v, Nothing) -> err $ DBLinkInvalidValue v False
+  (Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
+  (Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
+  (Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
   where
     go = return . Right . Right
+    err = throwAppError . DBError . DBLinkError k
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
 
 makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
-makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal' prec $ entryRValue e)
+makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
 
 insertAll
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
   => [EntryCRU]
   -> m ()
 insertAll ebs = do
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index fa234ce..fcc8b0a 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -37,7 +37,7 @@ splitHistory = partitionEithers . fmap go
 -- Transfers
 
 readHistTransfer
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
@@ -82,9 +82,9 @@ readImport_
   -> m [TxRecord]
 readImport_ n delim tns p = do
   res <- tryIO $ BL.readFile p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res
+  bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Left m -> throwIO $ AppException [ParseError $ T.pack m]
     Right (_, v) -> return $ catMaybes $ V.toList v
   where
     opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@@ -104,12 +104,12 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
+matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
     (ms_, [], []) -> return ms_
-    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
+    (_, us, ns) -> throwError $ AppException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
@@ -166,7 +166,7 @@ zipperMatch
   :: MonadFinance m
   => Unzipped MatchRe
   -> TxRecord
-  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -183,7 +183,7 @@ zipperMatch'
   :: MonadFinance m
   => Zipped MatchRe
   -> TxRecord
-  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -204,7 +204,7 @@ matchAll
   :: MonadFinance m
   => [MatchGroup]
   -> [TxRecord]
-  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -218,7 +218,7 @@ matchGroup
   :: MonadFinance m
   => MatchGroup
   -> [TxRecord]
-  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
@@ -228,7 +228,7 @@ matchDates
   :: MonadFinance m
   => [MatchRe]
   -> [TxRecord]
-  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -253,7 +253,7 @@ matchNonDates
   :: MonadFinance m
   => [MatchRe]
   -> [TxRecord]
-  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -270,7 +270,7 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
+matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -287,7 +287,7 @@ matches
       desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
       convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
 
-toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
+toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
 toTx
   priority
   TxGetter
@@ -329,7 +329,7 @@ resolveSubGetter
   :: MonadFinance m
   => TxRecord
   -> TxSubGetter
-  -> InsertExceptT m SecondayEntrySet
+  -> AppExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- asks csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
@@ -347,12 +347,12 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
         }
 
 resolveHalfEntry
-  :: (Precision -> TxRecord -> n -> InsertExcept v')
+  :: (Precision -> TxRecord -> n -> AppExcept v')
   -> Precision
   -> TxRecord
   -> v
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet v v')
+  -> AppExcept (HalfEntrySet v v')
 resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
@@ -369,7 +369,7 @@ resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntri
     acntRes = resolveAcnt r thgAcnt
     esRes = mapErrors (resolveEntry f prec r) thgEntries
 
-otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
+otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
 otherMatches dict m = case m of
   Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
   Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
@@ -377,25 +377,25 @@ otherMatches dict m = case m of
     lookup_ t n = lookupErr (MatchField t) n dict
 
 resolveEntry
-  :: (Precision -> TxRecord -> n -> InsertExcept v)
+  :: (Precision -> TxRecord -> n -> AppExcept v)
   -> Precision
   -> TxRecord
   -> EntryGetter n
-  -> InsertExcept (Entry AcntID v TagID)
+  -> AppExcept (Entry AcntID v TagID)
 resolveEntry f prec r s@Entry {eAcnt, eValue} =
   combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
   where
     acntRes = resolveAcnt r eAcnt
     valRes = f prec r eValue
 
-resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
+resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
 resolveFromValue = resolveValue
 
-resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
+resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
 resolveToValue _ _ (Linked l) = return $ LinkIndex l
 resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
 
-resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
+resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
 resolveValue prec TxRecord {trOther, trAmount} s = case s of
   (LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
   (ConstN c) -> return $ EntryFixed $ go c
@@ -403,20 +403,19 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
   BalanceN x -> return $ EntryBalance $ go x
   PercentN x -> return $ EntryPercent x
   where
-    go = realFracToDecimal' prec
+    go = realFracToDecimalP prec
 
-resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
+resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
 resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
 
-resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
+resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
 resolveCurrency m r c = do
   i <- resolveEntryField CurField r (unCurID <$> c)
   case M.lookup (CurID i) m of
     Just k -> return k
-    -- TODO this should be its own error (I think)
-    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
+    Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
 
-resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> InsertExcept T.Text
+resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
 resolveEntryField t TxRecord {trOther = o} s = case s of
   ConstT p -> return p
   LookupT f -> lookup_ f o
@@ -427,15 +426,15 @@ resolveEntryField t TxRecord {trOther = o} s = case s of
     (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
     lookup_ (k1, k2) m
   where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
     lookup_ = lookupErr (EntryIDField t)
 
-readDouble :: T.Text -> InsertExcept Double
+readDouble :: T.Text -> AppExcept Double
 readDouble s = case readMaybe $ T.unpack s of
   Just x -> return x
-  Nothing -> throwError $ InsertException [ConversionError s]
+  Nothing -> throwError $ AppException [ConversionError s True]
 
-readRational :: T.Text -> InsertExcept Rational
+readRational :: T.Text -> AppExcept Rational
 readRational s = case T.split (== '.') s of
   [x] -> maybe err (return . fromInteger) $ readT x
   [x, y] -> case (readT x, readT y) of
@@ -447,14 +446,14 @@ readRational s = case T.split (== '.') s of
   _ -> err
   where
     readT = readMaybe . T.unpack
-    err = throwError $ InsertException [ConversionError s]
+    err = throwError $ AppException [ConversionError s False]
 
-compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
+compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
 compileOptions o@TxOpts {toAmountFmt = pat} = do
   re <- compileRegex True pat
   return $ o {toAmountFmt = re}
 
-compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
+compileMatch :: StatementParser T.Text -> AppExcept MatchRe
 compileMatch m@StatementParser {spDesc, spOther} = do
   combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
   where
@@ -462,10 +461,10 @@ compileMatch m@StatementParser {spDesc, spOther} = do
     dres = mapM go spDesc
     ores = combineErrors $ fmap (mapM go) spOther
 
-compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
+compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
 compileRegex groups pat = case res of
   Right re -> return (pat, re)
-  Left _ -> throwError $ InsertException [RegexError pat]
+  Left _ -> throwError $ AppException [RegexError pat]
   where
     res =
       compile
@@ -473,10 +472,10 @@ compileRegex groups pat = case res of
         (blankExecOpt {captureGroups = groups})
         pat
 
-matchMaybe :: T.Text -> Regex -> InsertExcept Bool
+matchMaybe :: T.Text -> Regex -> AppExcept Bool
 matchMaybe q re = case execute re q of
   Right res -> return $ isJust res
-  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
+  Left _ -> throwError $ AppException [RegexError "this should not happen"]
 
 matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
 matchGroupsMaybe q re = case regexec re q of
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 476c955..3079e4e 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -26,6 +26,8 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types
 
+type MonadFinance = MonadReader ConfigState
+
 data DeleteTxs = DeleteTxs
   { dtTxs :: ![TransactionRId]
   , dtEntrySets :: ![EntrySetRId]
@@ -36,6 +38,7 @@ data DeleteTxs = DeleteTxs
 
 type CDOps c d = CRUDOps [c] () () [d]
 
+-- TODO split the entry stuff from the account metadata stuff
 data ConfigState = ConfigState
   { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
   , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
@@ -142,8 +145,6 @@ data EntryCRU
   | ToRead ReadEntry
   | ToInsert (Tx CommitR)
 
-type MonadFinance = MonadReader ConfigState
-
 -------------------------------------------------------------------------------
 -- misc
 
@@ -240,8 +241,6 @@ data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 --------------------------------------------------------------------------------
 -- exception types
 
-data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
-
 data MatchType = MatchNumeric | MatchText deriving (Show)
 
 data EntryIDType = AcntField | CurField | TagField deriving (Show)
@@ -253,42 +252,49 @@ data LookupSuberr
   | DBKey !EntryIDType
   deriving (Show)
 
-data AllocationSuberr
-  = NoAllocations
-  | ExceededTotal
-  | MissingBlank
-  | TooManyBlanks
-  deriving (Show)
-
 data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
 
-data InsertError
+data DBLinkSubError
+  = DBLinkNoScale
+  | DBLinkNoValue
+  | DBLinkInvalidValue !Rational !Bool
+  | DBLinkInvalidBalance
+  | DBLinkInvalidPercent
+  deriving (Show)
+
+data DBSubError
+  = DBShouldBeEmpty
+  | DBMultiScope
+  | DBUpdateUnbalanced
+  | DBLinkError !EntryRId !DBLinkSubError
+  deriving (Show)
+
+data AppError
   = RegexError !T.Text
   | MatchValPrecisionError !Natural !Natural
-  | AccountError !AcntID !(NE.NonEmpty AcntType)
-  | InsertIOError !T.Text
+  | AccountTypeError !AcntID !(NE.NonEmpty AcntType)
+  | StatementIOError !T.Text
   | ParseError !T.Text
-  | ConversionError !T.Text
-  | IndexError !(Entry AcntID LinkedNumGetter TagID) !Day
-  | RoundError !CurID
+  | ConversionError !T.Text !Bool
   | LookupError !LookupSuberr !T.Text
-  | IncomeError !Day !T.Text !Rational
-  | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
+  | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
   | PeriodError !Day !Day
+  | LinkError !EntryIndex !EntryIndex
+  | DBError !DBSubError
   deriving (Show)
 
-newtype InsertException = InsertException [InsertError]
-  deriving (Show, Semigroup) via [InsertError]
+newtype AppException = AppException [AppError]
+  deriving (Show, Semigroup) via [AppError]
 
-instance Exception InsertException
+instance Exception AppException
 
-type MonadInsertError = MonadError InsertException
+type MonadAppError = MonadError AppException
 
-type InsertExceptT = ExceptT InsertException
+type AppExceptT = ExceptT AppException
 
-type InsertExcept = InsertExceptT Identity
+type AppExcept = AppExceptT Identity
 
 type MatchRe = StatementParser (T.Text, Regex)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 6931fe9..3acf795 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -8,6 +8,7 @@ module Internal.Utils
   , resolveDaySpan
   , resolveDaySpan_
   , intersectDaySpan
+  , throwAppError
   , liftInner
   , liftExceptT
   , liftExcept
@@ -28,7 +29,6 @@ module Internal.Utils
   , mapErrorsIO
   , mapErrorsPooledIO
   , showError
-  , tshow
   , lookupErr
   , uncurry3
   , dateMatches
@@ -49,7 +49,7 @@ module Internal.Utils
   , entryPair
   , singleQuote
   , keyVals
-  , realFracToDecimal'
+  , realFracToDecimalP
   , roundToP
   )
 where
@@ -58,6 +58,7 @@ import Control.Monad.Error.Class
 import Control.Monad.Except
 import Data.Decimal
 import Data.Time.Format.ISO8601
+import qualified Database.Esqueleto.Experimental as E
 import GHC.Real
 import Internal.Types.Main
 import RIO
@@ -72,7 +73,7 @@ import qualified RIO.Vector as V
 --------------------------------------------------------------------------------
 -- intervals
 
-expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
+expandDatePat :: DaySpan -> DatePat -> AppExcept [Day]
 expandDatePat b (Cron cp) = expandCronPat b cp
 expandDatePat i (Mod mp) = return $ expandModPat mp i
 
@@ -91,7 +92,7 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
       Month -> addGregorianMonthsClip
       Year -> addGregorianYearsClip
 
-expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
+expandCronPat :: DaySpan -> CronPat -> AppExcept [Day]
 expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
   combineError3 yRes mRes dRes $ \ys ms ds ->
     filter validWeekday $
@@ -122,14 +123,14 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
       | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
       | otherwise = Just $ fromGregorian y m d
 
-expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
+expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [Natural]
 expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
 expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
 expandMDYPat lower upper (After x) = return [max lower x .. upper]
 expandMDYPat lower upper (Before x) = return [lower .. min upper x]
 expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
 expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
-  | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
+  | b < 1 = throwAppError $ DatePatternError s b r ZeroLength
   | otherwise = do
       k <- limit r
       return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
@@ -138,14 +139,14 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r
     limit (Just n)
       -- this guard not only produces the error for the user but also protects
       -- from an underflow below it
-      | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
+      | n < 1 = throwAppError $ DatePatternError s b r ZeroRepeats
       | otherwise = return $ min (s + b * (n - 1)) upper
 
 dayToWeekday :: Day -> Int
 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 
 askDays
-  :: (MonadFinance m, MonadInsertError m)
+  :: (MonadFinance m, MonadAppError m)
   => DatePat
   -> Maybe Interval
   -> m [Day]
@@ -224,7 +225,7 @@ inDaySpan bs = withinDays (fromDaySpan bs)
 withinDays :: (Day, Day) -> Day -> Bool
 withinDays (d0, d1) x = d0 <= x && x < d1
 
-resolveDaySpan :: Interval -> InsertExcept DaySpan
+resolveDaySpan :: Interval -> AppExcept DaySpan
 resolveDaySpan i@Interval {intStart = s} =
   resolveDaySpan_ (s {gYear = gYear s + 50}) i
 
@@ -237,14 +238,14 @@ intersectDaySpan a b =
     a' = max a0 a1
     b' = min b0 b1
 
-resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
+resolveDaySpan_ :: Gregorian -> Interval -> AppExcept DaySpan
 resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
   -- TODO the default isn't checked here :/
   case fromGregorian' <$> e of
     Nothing -> return $ toDaySpan_ $ fromGregorian' def
     Just e_
       | s_ < e_ -> return $ toDaySpan_ e_
-      | otherwise -> throwError $ InsertException [DaySpanError s e]
+      | otherwise -> throwAppError $ DaySpanError s e
   where
     s_ = fromGregorian' s
     toDaySpan_ end = toDaySpan (s_, end)
@@ -259,9 +260,9 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-valMatches :: ValMatcher -> Rational -> InsertExcept Bool
+valMatches :: ValMatcher -> Rational -> AppExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
-  | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
+  | Just d_ <- vmDen, d_ >= p = throwAppError $ MatchValPrecisionError d_ p
   | otherwise =
       return $
         checkMaybe (s ==) vmSign
@@ -279,6 +280,9 @@ dateMatches md = (EQ ==) . compareDate md
 --------------------------------------------------------------------------------
 -- error flow control
 
+throwAppError :: MonadAppError m => AppError -> m a
+throwAppError e = throwError $ AppException [e]
+
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
 
@@ -288,41 +292,37 @@ liftExceptT x = runExceptT x >>= either throwError return
 liftExcept :: MonadError e m => Except e a -> m a
 liftExcept = either throwError return . runExcept
 
-liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
+liftIOExceptT :: MonadIO m => AppExceptT m a -> m a
 liftIOExceptT = fromEither <=< runExceptT
 
-liftIOExcept :: MonadIO m => InsertExcept a -> m a
+liftIOExcept :: MonadIO m => AppExcept a -> m a
 liftIOExcept = fromEither . runExcept
 
-combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
+combineError :: MonadAppError m => m a -> m b -> (a -> b -> c) -> m c
 combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
 
-combineError_ :: MonadError InsertException m => m a -> m b -> m ()
+combineError_ :: MonadAppError m => m a -> m b -> m ()
 combineError_ a b = do
   _ <- catchError a $ \e ->
     throwError =<< catchError (e <$ b) (return . (e <>))
   _ <- b
   return ()
 
-combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
+combineErrorM :: MonadAppError m => m a -> m b -> (a -> b -> m c) -> m c
 combineErrorM a b f = do
   a' <- catchError a $ \e ->
     throwError =<< catchError (e <$ b) (return . (e <>))
   f a' =<< b
 
-combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
+combineError3 :: MonadAppError m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
 combineError3 a b c f =
   combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
 
-combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
+combineErrorM3 :: MonadAppError m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
 combineErrorM3 a b c f = do
   combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
 
-mapErrors
-  :: (Traversable t, MonadError InsertException m)
-  => (a -> m b)
-  -> t a
-  -> m (t b)
+mapErrors :: (Traversable t, MonadAppError m) => (a -> m b) -> t a -> m (t b)
 -- First, record number of each action. Then try each action. On first failure,
 -- note it's position in the sequence, skip ahead to the untried actions,
 -- collect failures and add to the first failure.
@@ -333,7 +333,7 @@ mapErrors f xs = mapM go $ enumTraversable xs
       throwError $ foldr (<>) e es
     err x = catchError (Nothing <$ x) (pure . Just)
 
-combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a)
+combineErrors :: (Traversable t, MonadAppError m) => t (m a) -> m (t a)
 combineErrors = mapErrors id
 
 enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
@@ -349,9 +349,9 @@ combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
 
 combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
 combineErrorIOM2 a b f = do
-  a' <- catch a $ \(InsertException es) ->
-    (throwIO . InsertException)
-      =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
+  a' <- catch a $ \(AppException es) ->
+    (throwIO . AppException)
+      =<< catch (es <$ b) (\(AppException es') -> return (es' ++ es))
   f a' =<< b
 
 combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
@@ -361,39 +361,39 @@ combineErrorIOM3 a b c f =
 mapErrorsPooledIO :: (Traversable t, MonadUnliftIO m) => Int -> (a -> m b) -> t a -> m (t b)
 mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs
   where
-    go (n, x) = catch (f x) $ \(InsertException e) -> do
+    go (n, x) = catch (f x) $ \(AppException e) -> do
       es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
-      throwIO $ InsertException $ foldr (<>) e es
-    err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
+      throwIO $ AppException $ foldr (<>) e es
+    err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
 
 mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
 mapErrorsIO f xs = mapM go $ enumTraversable xs
   where
-    go (n, x) = catch (f x) $ \(InsertException e) -> do
+    go (n, x) = catch (f x) $ \(AppException e) -> do
       es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
-      throwIO $ InsertException $ foldr (<>) e es
-    err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
+      throwIO $ AppException $ foldr (<>) e es
+    err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
 
 collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
+lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> AppExcept v
 lookupErr what k m = case M.lookup k m of
   Just x -> return x
-  _ -> throwError $ InsertException [LookupError what $ tshow k]
+  _ -> throwAppError $ LookupError what $ tshow k
 
 --------------------------------------------------------------------------------
 -- error display
 
-showError :: InsertError -> [T.Text]
+showError :: AppError -> [T.Text]
 showError other = case other of
-  (StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms)
+  (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
   (DaySpanError a b) ->
     [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
     where
       showGreg (Just g) = showGregorian_ g
       showGreg Nothing = "Inf"
-  (AccountError a ts) ->
+  (AccountTypeError a ts) ->
     [ T.unwords
         [ "account type of key"
         , singleQuote $ unAcntID a
@@ -403,7 +403,7 @@ showError other = case other of
     ]
     where
       ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts
-  (PatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
+  (DatePatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
     where
       pat =
         keyVals $
@@ -418,8 +418,15 @@ showError other = case other of
         ZeroLength -> "Zero repeat length"
         ZeroRepeats -> "Zero repeats"
   (RegexError re) -> [T.append "could not make regex from pattern: " re]
-  (ConversionError x) -> [T.append "Could not convert to rational number: " x]
-  (InsertIOError msg) -> [T.append "IO Error: " msg]
+  (ConversionError x isDouble) ->
+    [ T.unwords
+        [ "Could not convert to"
+        , if isDouble then "double" else "rational"
+        , "number: "
+        , x
+        ]
+    ]
+  (StatementIOError msg) -> [T.append "IO Error: " msg]
   (ParseError msg) -> [T.append "Parse Error: " msg]
   (MatchValPrecisionError d p) ->
     [T.unwords ["Match denominator", tshow d, "must be less than", tshow p]]
@@ -437,16 +444,6 @@ showError other = case other of
       idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
-  (IncomeError day name balance) ->
-    [ T.unwords
-        [ "Income allocations for budget"
-        , singleQuote name
-        , "exceed total on day"
-        , tshow day
-        , "where balance is"
-        , tshow (fromRational balance :: Double)
-        ]
-    ]
   (PeriodError start next) ->
     [ T.unwords
         [ "First pay period on "
@@ -455,28 +452,40 @@ showError other = case other of
         , singleQuote $ tshow next
         ]
     ]
-  (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
+  (LinkError i m) ->
     [ T.unwords
-        [ "No credit entry for index"
-        , singleQuote $ tshow lngIndex
-        , "for entry with account"
-        , singleQuote $ unAcntID eAcnt
-        , "on"
-        , tshow day
-        ]
-    ]
-  (RoundError cur) ->
-    [ T.unwords
-        [ "Could not look up precision for currency"
-        , singleQuote $ unCurID cur
+        [ "entry index"
+        , singleQuote $ tshow i
+        , "out of range: max index is"
+        , singleQuote $ tshow m
         ]
     ]
+  (DBError d) -> case d of
+    DBShouldBeEmpty -> ["database has no rows in 'config_state' but has other data"]
+    DBMultiScope -> ["database has multiple rows in 'config_state'"]
+    DBUpdateUnbalanced -> ["update is missing debit or credit entries"]
+    DBLinkError k l ->
+      let k' = T.append "in entry key: " $ tshow $ E.fromSqlKey k
+       in case l of
+            DBLinkNoScale -> [T.append "no link scale" k']
+            DBLinkNoValue -> [T.append "no link value" k']
+            DBLinkInvalidValue v isfixed ->
+              [ T.unwords
+                  [ if isfixed
+                      then "fixed link should not have value"
+                      else "untyped value is ambiguous"
+                  , singleQuote $ tshow v
+                  , k'
+                  ]
+              ]
+            DBLinkInvalidBalance -> [T.append "no value given for balance link" k']
+            DBLinkInvalidPercent -> [T.append "no value given for percent link" k']
 
 showGregorian_ :: Gregorian -> T.Text
 showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
 
-tshowx :: TxRecord -> T.Text
-tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
+showTx :: TxRecord -> T.Text
+showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
   T.append "Unmatched transaction: " $
     keyVals
       [ ("path", T.pack f)
@@ -589,29 +598,29 @@ mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
-lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
+lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
 lookupAccount = lookupFinance AcntField csAccountMap
 
-lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
+lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
 lookupAccountKey = fmap fst . lookupAccount
 
-lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
+lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap snd . lookupAccount
 
-lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
+lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
 lookupCurrency = lookupFinance CurField csCurrencyMap
 
-lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
+lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
 
-lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
+lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
-lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
+lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
 lookupTag = lookupFinance TagField csTagMap
 
 lookupFinance
-  :: (MonadInsertError m, MonadFinance m, Ord k, Show k)
+  :: (MonadAppError m, MonadFinance m, Ord k, Show k)
   => EntryIDType
   -> (ConfigState -> M.Map k a)
   -> k
@@ -619,7 +628,7 @@ lookupFinance
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
 
 balanceTxs
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => [EntryCRU]
   -> m ([UEBalanced], [InsertTx])
 balanceTxs ebs =
@@ -796,7 +805,7 @@ updateUnknown k e = do
 -- balancing
 
 balancePrimaryEntrySet
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => BudgetName
   -> PrimaryEntrySet
   -> StateT EntryBals m InsertEntrySet
@@ -821,7 +830,7 @@ balancePrimaryEntrySet
           balanceFinal bc (-esTotalValue) fs'' t0' ts'
 
 balanceSecondaryEntrySet
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => BudgetName
   -> SecondayEntrySet
   -> StateT EntryBals m InsertEntrySet
@@ -846,7 +855,7 @@ balanceSecondaryEntrySet
       bc = (esCurrency, budgetName)
 
 balanceFinal
-  :: (MonadInsertError m)
+  :: (MonadAppError m)
   => BCKey
   -> Decimal
   -> NonEmpty InsertEntry
@@ -865,7 +874,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
       }
 
 balanceTotalEntrySet
-  :: (MonadInsertError m)
+  :: (MonadAppError m)
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Decimal
@@ -890,19 +899,19 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
 
 balanceLinked
-  :: MonadInsertError m
+  :: MonadAppError m
   => Vector Decimal
   -> ABCKey
   -> EntryLink
   -> StateT EntryBals m (Decimal, Maybe CachedEntry)
 balanceLinked from k lg = case lg of
   (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
-    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
+    let i = fromIntegral lngIndex
+        upper = EntryIndex $ V.length from
+        res = fmap (go lngScale) $ from V.!? i
     case res of
       Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale))
-      -- TODO this error would be much more informative if I had access to the
-      -- file from which it came
-      Nothing -> throwError undefined
+      Nothing -> throwAppError $ LinkError (EntryIndex i) upper
   (LinkValue d) -> liftInnerS $ balanceDeferred k d
   where
     go s = negate . (*. s)
@@ -917,7 +926,7 @@ balanceDeferred k e = do
   return (newval, d)
 
 balanceEntry
-  :: (MonadInsertError m)
+  :: (MonadAppError m)
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Entry AccountRId v TagRId
@@ -932,7 +941,7 @@ balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
       }
 
 resolveAcntAndTags
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => Entry AcntID v TagID
   -> m (Entry AccountRId v TagRId)
 resolveAcntAndTags e@Entry {eAcnt, eTags} = do
@@ -952,7 +961,7 @@ findBalance k e = do
 -- transfers
 
 expandTransfers
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => CommitR
   -> BudgetName
   -> DaySpan
@@ -961,7 +970,7 @@ expandTransfers
 expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
 
 expandTransfer
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadAppError m, MonadFinance m)
   => CommitR
   -> BudgetName
   -> DaySpan
@@ -980,7 +989,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         } = do
         cp <- lookupCurrency transCurrency
         let v' = (-v)
-        let dec = realFracToDecimal' (cpPrec cp) v'
+        let dec = realFracToDecimalP (cpPrec cp) v'
         let v'' = case t of
               TFixed -> EntryFixed dec
               TPercent -> EntryPercent v'
@@ -1021,7 +1030,7 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
         }
 
 withDates
-  :: (MonadFinance m, MonadInsertError m)
+  :: (MonadFinance m, MonadAppError m)
   => DaySpan
   -> DatePat
   -> (Day -> m a)
@@ -1036,8 +1045,8 @@ 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, [])
 
-realFracToDecimal' :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
-realFracToDecimal' p = realFracToDecimal (unPrecision p)
+realFracToDecimalP :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
+realFracToDecimalP p = realFracToDecimal (unPrecision p)
 
 roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
 roundToP p = roundTo (unPrecision p)