WIP allow running balances to be used in history

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
+    FLookupN: lookup the value from a field
-    ConstN: a constant value
+    FConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    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
+      { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      , 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
+          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      , default = { eValue = None ToEntryNumGetter, eComment = "" }
       }
 
 let TxGetter =
@@ -1073,7 +1088,8 @@ in  { CurID
     , DateMatcher
     , FieldMatcher
     , FieldMatcher_
-    , EntryNumGetter
+    , FromEntryNumGetter
+    , ToEntryNumGetter
     , Field
     , FieldMap
     , Entry

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
         }

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
+            return $ fmap tx days
-            mapM_ (insertTx c) keys
+      concat <$> mapErrors go amts
-      void $ combineErrors $ fmap 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
+  return $ filter (inDaySpan bounds . txDate) bs
-
-insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
-insertHistStmt c ks = do
-  ck <- insert c
-  mapM_ (insertTx ck) ks
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
 -- TODO tags here?
 txPair
-  :: (MonadInsertError m, MonadFinance m)
+  :: Day
-  => Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> m KeyTx
+  -> RawTx
-txPair day from to cur val desc = resolveTx tx
+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
+balanceTxs
-balanceTx t@Tx {txEntries = ss} = do
+  :: (MonadInsertError m, MonadFinance m)
-  bs <- balanceEntries ss
+  => [(CommitR, RawTx)]
-  return $ t {txEntries = bs}
+  -> 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)

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
 

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)

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)
+      let fromEntry =
-          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
+resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
-resolveValue TxRecord {trOther, trAmount} s = case s of
+resolveFromValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+  (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return c
+  (FConstN c) -> return $ ConstD c
-  AmountN m -> return $ (* m) $ fromRational trAmount
+  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)