ENH use sane types to simplify tx balancing

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
+    LookupN: lookup the value from a field
-    FConstN: a constant value
+    ConstN: a constant value
-    FAmountN: the value of the 'Amount' column
+    AmountN: the value of the 'Amount' column
-    FBalanceN: the amount required to make the target account reach a balance
+    BalanceN: the amount required to make the target account reach a balance
     -}
-      < FLookupN : Text
+      < LookupN : Text
-      | FConstN : Double
+      | ConstN : Double
-      | FAmountN : Double
+      | AmountN : Double
-      | FBalanceN : 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
+    Means for getting an entry from a given row in a statement
-    credit side of the transaction.
     -}
-      { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
+      { Type = Entry EntryAcntGetter EntryNumGetter TagID
-      , default = { eValue = None FromEntryNumGetter, eComment = "" }
+      , 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
+    A means for transforming one row in a statement to a transaction
-    debit side of the transaction.
     -}
-      { Type =
+      { tsgFromAcnt :
-          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
+          {-
-      , default = { eValue = None ToEntryNumGetter, eComment = "" }
+          -}
+          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
+    At least two entries must be made for any given transaction. Below these
-    Nth entry will be balanced with the others.
+    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
+    , EntryNumGetter
-    , ToEntryNumGetter
     , Field
     , FieldMap
     , Entry
-    , FromEntryGetter
+    , EntryGetter
-    , ToEntryGetter
     , EntryTextGetter
     , EntryCurGetter
     , EntryAcntGetter

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
+insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do
-  k <- insert $ EntryR t eCurrency eAcnt eComment eValue
+  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
+        { feCurrency = cid
-        , eCurrency = cid
+        , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
-        , eValue = fromIntegral (sign2Int sign) * eValue
-        , eTags = tags
         }

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
+  -> DeferredTx
-txPair day from to cur val desc = tx
+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} =
+resolveTx t@Tx {dtxEntries = ss} =
-  fmap (\kss -> t {txEntries = kss}) $ combineErrors $ fmap resolveEntry 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'
+  keyts <- mapErrors resolveTx balTs
-  return $ zip cs bs
+  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
+type EntryBals = M.Map (AcntID, CurID) Rational
-  :: (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
 
-balanceEntryTargets
+-- TODO might be faster to also do all the key stuff here since currency
-  :: (Ord a, Ord c)
+-- will be looked up for every entry rather then the entire entry set
-  => M.Map (a, c) Rational
+balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
-  -> Entry a (Deferred Rational) c t
+balanceEntrySet
-  -> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
+  bals
-balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
+  EntrySet
+    { desFromEntry0
+    , desFromEntries
+    , desToEntryBal
+    , desToEntries
+    , desCurrency
+    , desTotalValue
+    } = flipTup $ runState doBalAll bals
     where
-    key = (eAcnt, eCurrency)
+      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, curID)
     curBal = M.findWithDefault 0 key bals
-    v = case eValue of
+    newVal = v - curBal
-      ConstD x -> Just x
+    bals' = mapAdd_ key newVal bals
-      Target x -> Just $ x - curBal
-      Derive -> Nothing
-    bals' = maybe bals (\y -> mapAdd_ key y bals) v
 
-balanceTx
+-- -- reimplementation from future version :/
-  :: (MonadInsertError m, MonadFinance m)
+-- mapAccumM
-  => Tx (Entry AcntID (Maybe Rational) CurID TagID)
+--   :: Monad m
-  -> m KeyTx
+--   => (s -> a -> m (s, b))
-balanceTx t@Tx {txEntries = ss} = do
+--   -> s
-  bs <- liftExcept $ balanceEntries ss
+--   -> [a]
-  resolveTx $ t {txEntries = bs}
+--   -> m (s, [b])
-
+-- mapAccumM f s xs = foldrM go (s, []) xs
-balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
+--   where
-balanceEntries ss =
+--     go x (s', acc) = second (: acc) <$> f s' x
-  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 (: []))

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 "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
-  , MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
   , 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"
+  , "EntryNumGetter"
-  , "ToEntryNumGetter"
   , "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 EntryNumGetter
-
-deriving instance Hashable ToEntryNumGetter
 
 -------------------------------------------------------------------------------
 -- 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 (Eq a, Eq v, Eq t) => Eq (Entry a v 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)
 
 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
+  , tgToAcnt :: !EntryAcnt
-  , tgFromEntries :: ![FromEntryGetter]
+  , tgCurrency :: !EntryCur
-  , tgToEntries :: ![ToEntryGetter]
+  , tgFromEntries :: ![EntryGetter]
+  , tgToEntries :: ![EntryGetter]
+  , tgOtherEntries :: ![TxSubGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 

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

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} =
+      convert tg = MatchPass <$> toTx tg r
-        MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r
 
+toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
 toTx
-  :: EntryCur
+  TxGetter {tgFromAcnt, tgToAcnt, tgCurrency, tgFromEntries, tgToEntries, tgOtherEntries}
-  -> EntryAcnt
+  r@TxRecord {trAmount, trDate, trDesc} = do
-  -> [FromEntryGetter]
+    combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> do
-  -> [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 fromEntry =
             Entry
-              { eAcnt = a
+              { eAcnt = fa
-              , eCurrency = c
+              , eValue = ()
-              , eValue = ConstD trAmount
               , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
+          toEntry =
+            Entry
+              { eAcnt = ta
+              , eValue = ()
+              , eComment = ""
+              , eTags = []
+              }
        in Tx
-            { txDate = trDate
+            { dtxDate = trDate
-            , txDescr = trDesc
+            , dtxDescr = trDesc
-            , txEntries = fromEntry : fs ++ ts
+            , dtxEntries =
+                EntrySet
+                  { desTotalValue = trAmount
+                  , desCurrency = cur
+                  , desFromEntry0 = fromEntry
+                  , desFromEntries = fe
+                  , desToEntries = te
+                  , desToEntryBal = toEntry
+                  }
+                  : ss
             }
     where
-    acntRes = liftInner $ resolveAcnt r sa
+      resolveAcnt_ = liftInner . resolveAcnt r
-    curRes = liftInner $ resolveCurrency r sc
+      acntRes =
-    fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
+        combineError
-    toRes = combineErrors $ fmap (resolveToEntry r) toEntries
+          (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
+-- TODO this should be more general?
-resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+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
+  liftInner $ combineErrorM acntRes valRes $ \a v -> do
-    v' <- mapM (roundPrecisionCur c m) v
+    v' <- mapM (roundPrecisionCur cur m) v
-    return $ s {eAcnt = a, eValue = v', eCurrency = c}
+    return $ s {eAcnt = a, eValue = v'}
   where
     acntRes = resolveAcnt r eAcnt
-    curRes = resolveCurrency r eCurrency
+    valRes = resolveValue r eValue
-    valRes = resolveFromValue r eValue
 
--- TODO wet code (kinda, not sure if it's worth combining with above)
+-- curRes = resolveCurrency r eCurrency
-resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
+
-resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+-- -- TODO wet code (kinda, not sure if it's worth combining with above)
-  m <- ask
+-- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+-- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-    v' <- mapM (roundPrecisionCur c m) v
+--   m <- ask
-    return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
+--   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-  where
+--     v' <- mapM (roundPrecisionCur c m) v
-    acntRes = resolveAcnt r eAcnt
+--     return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
-    curRes = resolveCurrency r eCurrency
+--   where
-    valRes = mapM (resolveToValue r) eValue
+--     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]
+enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
-mapErrors f xs = do
+enumTraversable = snd . L.mapAccumL go 0
-  ys <- mapM (go . f) xs
-  case partitionEithers ys of
-    ([], zs) -> return zs
-    (e : es, _) -> throwError $ foldr (<>) e es
   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 :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
-mapErrorsIO f xs = do
+mapErrorsIO f xs = mapM go $ enumTraversable xs
-  ys <- mapM (go . f) xs
-  case partitionEithers ys of
-    ([], zs) -> return zs
-    (es, _) -> throwIO $ InsertException $ concat es
   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)
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
-resolveFromValue TxRecord {trOther, trAmount} s = case s of
+resolveValue TxRecord {trOther, trAmount} s = case s of
-  (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (FConstN c) -> return $ ConstD c
+  (ConstN c) -> return $ Deferred False c
-  FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
+  AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
-  FBalanceN x -> return $ Target x
+  BalanceN x -> return $ Deferred True x
 
--- TODO not DRY
+-- -- TODO not DRY
-resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
+-- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
-resolveToValue TxRecord {trOther, trAmount} s = case s of
+-- resolveToValue TxRecord {trOther, trAmount} s = case s of
-  (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+--   (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
-  (TConstN c) -> return c
+--   (TConstN c) -> return c
-  TAmountN m -> return $ (* m) $ fromRational trAmount
+--   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