ENH use sane types to simplify tx balancing

2023-06-16 22:05:28 -04:00 · 2023-06-16 22:05:28 -04:00 · ad0975aba7
parent 6926003c46
commit ad0975aba7
6 changed files with 411 additions and 264 deletions
--- 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
--- 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}
        }
--- 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
--- 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)

--- 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]
--- 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