app/Main.hs

@@ -180,13 +180,13 @@ runSync c = do
 
     -- update the DB
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      let runHist = do
+      let hTransRes = mapErrors insertHistTransfer hTs
-            ts <- catMaybes <$> mapErrors readHistTransfer hTs
+      let bgtRes = mapErrors insertBudget $ budget config
-            insertHistory $ bSs ++ ts
-      let runBudget = mapErrors insertBudget $ budget config
       updateDBState updates -- TODO this will only work if foreign keys are deferred
-      res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
+      res <- runExceptT $ do
-      rerunnableIO $ fromEither res -- TODO why is this here?
+        mapM_ (uncurry insertHistStmt) bSs
+        combineError hTransRes bgtRes $ \_ _ -> ()
+      rerunnableIO $ fromEither res
   where
     root = takeDirectory c
     err (InsertException es) = do

dhall/Types.dhall

@@ -396,30 +396,15 @@ 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
     -}
-      < FLookupN : Text
+      < LookupN : Text | ConstN : Double | AmountN : Double >
-      | 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 =
     {-
@@ -492,8 +477,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 FromEntryNumGetter EntryCurGetter TagID
+      { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID
-      , default = { eValue = None FromEntryNumGetter, eComment = "" }
+      , default = { eValue = None EntryNumGetter, eComment = "" }
       }
 
 let ToEntryGetter =
@@ -502,8 +487,8 @@ let ToEntryGetter =
     debit side of the transaction.
     -}
       { Type =
-          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
+          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None ToEntryNumGetter, eComment = "" }
+      , default = { eValue = None EntryNumGetter, eComment = "" }
       }
 
 let TxGetter =
@@ -1088,8 +1073,7 @@ in  { CurID
     , DateMatcher
     , FieldMatcher
     , FieldMatcher_
-    , FromEntryNumGetter
+    , EntryNumGetter
-    , ToEntryNumGetter
     , Field
     , FieldMap
     , Entry

dhall/common.dhall

@@ -96,7 +96,7 @@ let partN =
         let toEntry =
               \(x : PartEntry) ->
                     nullEntry (T.EntryAcntGetter.ConstT x._1) c
-                //  { eValue = Some (T.ToEntryNumGetter.TConstN x._2)
+                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
                     , eComment = x._3
                     }
 

lib/Internal/Budget.hs

@@ -74,6 +74,10 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
     amtToMove bal BTPercent x = -(x / 100 * bal)
     amtToMove bal BTTarget x = x - bal
 
+-- TODO this seems too general for this module
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
+
 insertBudgetTx
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => BalancedTransfer

lib/Internal/Database.hs

@@ -411,6 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
       s
         { eAcnt = aid
         , eCurrency = cid
-        , eValue = fromIntegral (sign2Int sign) * eValue
+        , eValue = eValue * fromIntegral (sign2Int sign)
         , eTags = tags
         }

lib/Internal/History.hs

@@ -1,8 +1,8 @@
 module Internal.History
-  ( readHistStmt
+  ( splitHistory
-  , readHistTransfer
+  , insertHistTransfer
-  , insertHistory
+  , readHistStmt
-  , splitHistory
+  , insertHistStmt
   )
 where
 
@@ -17,92 +17,72 @@ 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
 
--- readHistory
---   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
---   => FilePath
---   -> [History]
---   -> m [(CommitR, [RawTx])]
--- readHistory root hs = do
---   let (ts, ss) = splitHistory hs
---   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
---   ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
---   return $ ts' ++ ss'
-
-readHistTransfer
-  :: (MonadInsertError m, MonadFinance m)
-  => HistTransfer
-  -> m (Maybe (CommitR, [RawTx]))
-readHistTransfer
-  m@Transfer
-    { transFrom = from
-    , transTo = to
-    , transCurrency = u
-    , transAmounts = amts
-    } = 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
-            return $ fmap tx days
-      concat <$> mapErrors go amts
-
-groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
-groupKey f = fmap go . NE.groupAllWith (f . fst)
-  where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
-
-readHistStmt
-  :: (MonadUnliftIO m, MonadFinance m)
-  => FilePath
-  -> Statement
-  -> m (Maybe (CommitR, [RawTx]))
-readHistStmt root i = whenHash_ CTImport i $ do
-  bs <- readImport root i
-  bounds <- askDBState kmStatementInterval
-  return $ filter (inDaySpan bounds . txDate) bs
-
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
   where
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-insertHistory
+insertHistTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [(CommitR, [RawTx])]
+  => HistTransfer
   -> m ()
-insertHistory hs = do
+insertHistTransfer
-  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
+  m@Transfer
-  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
+    { transFrom = from
-    ck <- insert c
+    , transTo = to
-    mapM_ (insertTx ck) ts
+    , transCurrency = u
+    , transAmounts = amts
+    } = do
+    whenHash CTManual m () $ \c -> do
+      bounds <- askDBState kmStatementInterval
+      let precRes = lookupCurrencyPrec u
+      let go Amount {amtWhen, amtValue, amtDesc} = do
+            let dayRes = liftExcept $ expandDatePat bounds amtWhen
+            (days, precision) <- combineError dayRes precRes (,)
+            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
+            keys <- combineErrors $ fmap tx days
+            mapM_ (insertTx c) keys
+      void $ combineErrors $ fmap go amts
+
+readHistStmt
+  :: (MonadUnliftIO m, MonadFinance m)
+  => FilePath
+  -> Statement
+  -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt root i = whenHash_ CTImport i $ do
+  bs <- readImport root i
+  bounds <- askDBState kmStatementInterval
+  liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
+
+insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
+insertHistStmt c ks = do
+  ck <- insert c
+  mapM_ (insertTx ck) ks
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
 -- TODO tags here?
 txPair
-  :: Day
+  :: (MonadInsertError m, MonadFinance m)
+  => Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> RawTx
+  -> m KeyTx
-txPair day from to cur val desc = tx
+txPair day from to cur val desc = resolveTx tx
   where
     split a v =
       Entry
         { eAcnt = a
-        , eValue = ConstD v
+        , eValue = v
         , eComment = ""
         , eCurrency = cur
         , eTags = []
@@ -129,7 +109,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 [BalTx]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
@@ -175,13 +155,11 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
--- TODO need to somehow balance temporally here (like I do in the budget for
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
--- 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_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
+    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
@@ -325,49 +303,12 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTxs
+balanceTx :: RawTx -> InsertExcept BalTx
-  :: (MonadInsertError m, MonadFinance m)
-  => [(CommitR, RawTx)]
-  -> m [(CommitR, KeyTx)]
-balanceTxs ts = do
-  bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
-  return $ zip cs bs
-  where
-    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
-
-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
-
-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})
-  where
-    key = (eAcnt, eCurrency)
-    curBal = M.findWithDefault 0 key bals
-    v = case eValue of
-      ConstD x -> Just x
-      Target x -> Just $ x - curBal
-      Derive -> Nothing
-    bals' = maybe bals (\y -> mapAdd_ key y bals) v
-
-balanceTx
-  :: (MonadInsertError m, MonadFinance m)
-  => Tx (Entry AcntID (Maybe Rational) CurID TagID)
-  -> m KeyTx
 balanceTx t@Tx {txEntries = ss} = do
-  bs <- liftExcept $ balanceEntries ss
+  bs <- balanceEntries ss
-  resolveTx $ t {txEntries = bs}
+  return $ t {txEntries = bs}
 
-balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
+balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
 balanceEntries ss =
   fmap concat
     <$> mapM (uncurry bal)

lib/Internal/Types/Dhall.hs

@@ -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,9 +421,9 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
+type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
 
-type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
+type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID
 
 instance FromDhall ToEntryGetter
 

lib/Internal/Types/Main.hs

@@ -59,12 +59,8 @@ 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)
@@ -131,12 +127,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-data Deferred a = ConstD a | Target a | Derive
+type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
-  deriving (Show, Functor, Foldable, Traversable)
 
-type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
+type RawFromEntry = Entry AcntID Rational CurID TagID
-
--- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 type BalEntry = Entry AcntID Rational CurID TagID
 
@@ -179,7 +172,7 @@ data InsertError
   | ParseError !T.Text
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
-  | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
+  | BalanceError !BalanceType !CurID ![RawEntry]
   | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)

lib/Internal/Utils.hs

@@ -55,7 +55,6 @@ module Internal.Utils
   , lookupCurrencyKey
   , lookupCurrencyPrec
   , lookupTag
-  , mapAdd_
   )
 where
 
@@ -320,24 +319,26 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
     (combineError acntRes curRes (,))
     (combineError fromRes toRes (,))
     $ \(a, c) (fs, ts) ->
-      let fromEntry =
+      let fromValue = trAmount - sum (fmap eValue fs)
+          fromEntry =
             Entry
               { eAcnt = a
               , eCurrency = c
-              , eValue = ConstD trAmount
+              , eValue = Just fromValue
               , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
        in Tx
             { txDate = trDate
             , txDescr = trDesc
-            , txEntries = fromEntry : fs ++ ts
+            , txEntries = fromEntry : fmap liftEntry 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
@@ -363,16 +364,16 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
+resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry
 resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   m <- ask
   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-    v' <- mapM (roundPrecisionCur c m) v
+    v' <- roundPrecisionCur c m v
     return $ s {eAcnt = a, eValue = v', eCurrency = c}
   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
@@ -380,11 +381,11 @@ 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}
+    return $ s {eAcnt = a, eValue = v', eCurrency = c}
   where
     acntRes = resolveAcnt r eAcnt
     curRes = resolveCurrency r eCurrency
-    valRes = mapM (resolveToValue r) eValue
+    valRes = mapM (resolveValue r) eValue
 
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
@@ -469,19 +470,11 @@ mapErrorsIO f xs = do
 collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
 collectErrorsIO = mapErrorsIO id
 
-resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept 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) -> readDouble =<< lookupErr EntryValField t trOther
-  (FConstN c) -> return $ ConstD c
+  (ConstN c) -> return c
-  FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
+  AmountN m -> return $ (* 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
@@ -757,7 +750,7 @@ showMatchOther (Val (Field f mv)) =
     , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
-showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
+showEntry :: RawEntry -> T.Text
 showEntry Entry {eAcnt, eValue, eComment} =
   keyVals
     [ ("account", eAcnt)
@@ -856,9 +849,6 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 -- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
 -- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 
-mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
-mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
-
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c