FIX actually the multi typo

app/Main.hs

@@ -4,18 +4,13 @@ module Main (main) where
 
 import Control.Concurrent
 import Control.Monad.Except
-import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
-import Control.Monad.Reader
 import Data.Bitraversable
 -- import Data.Hashable
 import qualified Data.Text.IO as TI
 import qualified Database.Esqueleto.Experimental as E
-import Database.Persist.Monad
 import qualified Dhall hiding (double, record)
-import Internal.Budget
 import Internal.Database
-import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import Options.Applicative
@@ -72,7 +67,7 @@ options =
     <|> getConf dumpCurrencies
     <|> getConf dumpAccounts
     <|> getConf dumpAccountKeys
-    <|> getConf sync
+    <|> getConf sync_
   where
     getConf m = Options <$> configFile <*> m
 
@@ -113,8 +108,8 @@ dumpAccountKeys =
         <> help "Dump all account keys/aliases"
     )
 
-sync :: Parser Mode
-sync =
+sync_ :: Parser Mode
+sync_ =
   flag'
     Sync
     ( long "sync"
@@ -209,50 +204,14 @@ runDumpAccountKeys c = do
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
 runSync threads c bs hs = do
   setNumCapabilities threads
-  -- putStrLn "reading config"
   config <- readConfig c
-  -- putStrLn "reading statements"
   (bs', hs') <-
     fmap (bimap concat concat . partitionEithers) $
       pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
         (Left <$> bs) ++ (Right <$> hs)
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
-  putStrLn "doing other stuff"
   setNumCapabilities 1
-  handle err $ do
-    -- _ <- askLoggerIO
-
-    -- Get the current DB state.
-    state <- runSqlQueryT pool $ do
-      runMigration migrateAll
-      liftIOExceptT $ readConfigState config bs' hs'
-
-    -- Read raw transactions according to state. If a transaction is already in
-    -- the database, don't read it but record the commit so we can update it.
-    toIns <-
-      flip runReaderT state $ do
-        (CRUDOps hSs _ _ _) <- asks csHistStmts
-        hSs' <- mapErrorsIO (readHistStmt root) hSs
-        (CRUDOps hTs _ _ _) <- asks csHistTrans
-        hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        (CRUDOps bTs _ _ _) <- asks csBudgets
-        bTs' <- liftIOExceptT $ mapErrors readBudget bTs
-        return $ concat $ hSs' ++ hTs' ++ bTs'
-
-    -- Update the DB.
-    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      -- NOTE this must come first (unless we defer foreign keys)
-      updateDBState
-      res <- runExceptT $ do
-        (CRUDOps _ bRs bUs _) <- asks csBudgets
-        (CRUDOps _ tRs tUs _) <- asks csHistTrans
-        (CRUDOps _ sRs sUs _) <- asks csHistStmts
-        let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
-        insertAll ebs
-      -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-      -- whatever error is encountered above in an IO context, but the first
-      -- thrown error should be caught despite possibly needing to be rerun
-      rerunnableIO $ fromEither res
+  handle err $ sync pool root config bs' hs'
   where
     root = takeDirectory c
     err (AppException es) = do

dhall/Types.dhall

@@ -278,10 +278,52 @@ let DatePat =
     -}
       < Cron : CronPat.Type | Mod : ModPat.Type >
 
-let TxOpts_ =
-    {- Additional metadata to use when parsing a statement -}
+let TxAmount1_ =
+      \(re : Type) ->
+        { a1Column : Text
+        , a1Fmt :
+            {-
+            Format of the amount field. Must include three fields for the
+            sign, numerator, and denominator of the amount.
+            -}
+            re
+        }
+
+let TxAmount1 =
+      { Type = TxAmount1_ Text
+      , default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
+      }
+
+let TxAmount2_ =
+      \(re : Type) ->
+        { a2Positive : Text
+        , a2Negative : Text
+        , a2Fmt :
+            {-
+            Format of the amount field. Must include two fields for the
+            numerator and denominator of the amount.
+            -}
+            re
+        }
+
+let TxAmount2 =
+      { Type = TxAmount2_ Text
+      , default =
+        { a2Positive = "Deposit"
+        , a2Negative = "Withdraw"
+        , a2Fmt = "([0-9\\.]+)"
+        }
+      }
+
+let TxAmountSpec_ =
+      \(re : Type) ->
+        < AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
+
+let TxOpts_ =
+    {-
+    Additional metadata to use when parsing a statement
+    -}
       \(re : Type) ->
-        { Type =
         { toDate :
             {-
             Column title for date
@@ -291,7 +333,7 @@ let TxOpts_ =
             {-
             Column title for amount
             -}
-                Text
+            TxAmountSpec_ re
         , toDesc :
             {-
             Column title for description
@@ -309,24 +351,54 @@ let TxOpts_ =
             Data.Time.Format.formattime Haskell function.
             -}
             Text
-            , toAmountFmt :
-                {- Format of the amount field. Must include three fields for the
-                sign, numerator, and denominator of the amount.
+        , toSkipBlankDate :
+            {-
+            Skip line if date field is a blank
             -}
-                re
+            Bool
+        , toSkipBlankAmount :
+            {-
+            Skip line if amount field(s) is(are) a blank
+            -}
+            Bool
+        , toSkipBlankDescription :
+            {-
+            Skip line if description field is a blank
+            -}
+            Bool
+        , toSkipBlankOther :
+            {-
+            Skip line if any arbitrary fields are blank (these fields must also
+            be listed in 'toOther' to be considered)
+            -}
+            List Text
+        , toSkipMissingFields :
+            {-
+            Skip line if any fields are missing (this is different from blank;
+            'missing' means there is no field with name 'X', 'blank' means that
+            there is a field 'X' and its value is an empty string)
+            -}
+            Bool
         }
+
+let TxAmountSpec = TxAmountSpec_ Text
+
+let TxOpts =
+      { Type = TxOpts_ Text
       , default =
         { toDate = "Date"
-          , toAmount = "Amount"
+        , toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
         , toDesc = "Description"
         , toOther = [] : List Text
         , toDateFmt = "%0m/%0d/%Y"
-          , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
+        , toSkipBlankDate = False
+        , toSkipBlankAmount = False
+        , toSkipBlankDescription = False
+        , toSkipBlankOther = [] : List Text
+        , toSkipMissingFields = False
         }
       }
 
-let TxOpts = TxOpts_ Text
-
 let Field =
     {-
     General key-value type
@@ -984,40 +1056,23 @@ let Income =
         }
       }
 
-let AcntSet =
+let AcntMatcher_ =
     {-
-    A list of account IDs represented as a set.
+    Regex pattern by which matching account ids will be identified
     -}
-      { Type =
-          { asList : List AcntID
-          , asInclude :
-              {-
-              If true, tests for account membership in this set will return
-              true if the account is in the set. Invert this behavior otherwise.
-              -}
-              Bool
-          }
-      , default = { asList = [] : List AcntID, asInclude = False }
-      }
+      \(re : Type) ->
+        { Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
 
-let TransferMatcher =
+let AcntMatcher = AcntMatcher_ Text
+
+let TransferMatcher_ =
     {-
     Means to match a transfer (which will be used to "clone" it in some
     fashion)
     -}
-      { Type =
-          { tmFrom :
-              {-
-              List of accounts (which may be empty) to match with the
-              starting account in a transfer.
-              -}
-              AcntSet.Type
-          , tmTo :
-              {-
-              List of accounts (which may be empty) to match with the
-              ending account in a transfer.
-              -}
-              AcntSet.Type
+      \(re : Type) ->
+        { tmFrom : Optional (AcntMatcher_ re).Type
+        , tmTo : Optional (AcntMatcher_ re).Type
         , tmDate :
             {-
             If given, means to match the date of a transfer.
@@ -1029,9 +1084,12 @@ let TransferMatcher =
             -}
             ValMatcher.Type
         }
+
+let TransferMatcher =
+      { Type = TransferMatcher_ Text
       , default =
-        { tmFrom = AcntSet.default
-        , tmTo = AcntSet.default
+        { tmFrom = None AcntMatcher.Type
+        , tmTo = None AcntMatcher.Type
         , tmDate = None DateMatcher
         , tmVal = ValMatcher.default
         }
@@ -1069,7 +1127,6 @@ let ShadowTransfer =
           specified in other fields of this type.
           -}
           TransferMatcher.Type
-      , stType : TransferType
       , stRatio :
           {-
           Fixed multipler to translate value of matched transfer to this one.
@@ -1149,9 +1206,9 @@ in  { CurID
     , Budget
     , Allocation
     , Amount
+    , TransferMatcher_
     , TransferMatcher
     , ShadowTransfer
-    , AcntSet
     , TaggedAcnt
     , AccountTree
     , Account
@@ -1178,4 +1235,13 @@ in  { CurID
     , TransferAmount
     , MultiAlloAmount
     , SingleAlloAmount
+    , AcntMatcher_
+    , AcntMatcher
+    , TxAmountSpec
+    , TxAmountSpec_
+    , TxAmount1_
+    , TxAmount2_
+    , TxAmount1
+    , TxAmount2
+    , BudgetTransfer
     }

lib/Internal/Budget.hs

@@ -1,4 +1,4 @@
-module Internal.Budget (readBudget) where
+module Internal.Budget (readBudgetCRUD) where
 
 import Control.Monad.Except
 import Data.Decimal hiding (allocate)
@@ -13,7 +13,12 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
-readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
+readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
+readBudgetCRUD o@CRUDOps {coCreate} = do
+  bs <- mapM readBudget coCreate
+  return $ o {coCreate = bs}
+
+readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
 readBudget
   b@Budget
     { bgtLabel
@@ -27,15 +32,14 @@ readBudget
     } =
     do
       spanRes <- getSpan
-      case spanRes of
+      (bgtLabel,) <$> case spanRes of
         Nothing -> return []
         Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
-          txs <- combineError (concat <$> res1) res2 (++)
-          shadow <- addShadowTransfers bgtShadowTransfers txs
-          return $ txs ++ shadow
+          let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers c budgetSpan bgtTransfers
+          combineErrorM (concat <$> res1) res2 $ \is ts ->
+            addShadowTransfers bgtShadowTransfers (is ++ ts)
     where
       c = CommitR (CommitHash $ hash b) CTBudget
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
@@ -49,7 +53,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- asks (unBSpan . csBudgetScope)
+        globalSpan <- asks (unBSpan . tsBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -78,14 +82,12 @@ sortAllo a@Allocation {alloAmts = as} = do
 readIncome
   :: (MonadAppError m, MonadFinance m)
   => CommitR
-  -> BudgetName
   -> IntAllocations
   -> DaySpan
   -> Income
   -> m [Tx CommitR]
 readIncome
   key
-  name
   (intPre, intTax, intPost)
   ds
   Income
@@ -143,20 +145,16 @@ readIncome
         let allos = allo2Trans <$> (pre ++ tax ++ post)
         let primary =
               EntrySet
-                { esTotalValue = gross
+                { esTotalValue = -gross
                 , esCurrency = cpID cp
                 , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
                 , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
                 }
         return $
           Tx
-            { txCommit = key
-            , txDate = day
+            { txMeta = TxMeta day incPriority (TxDesc "") key
             , txPrimary = Left primary
             , txOther = []
-            , txDescr = TxDesc ""
-            , txBudget = name
-            , txPriority = incPriority
             }
 
 periodScaler
@@ -347,24 +345,32 @@ fromShadow
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
-  combineErrorM curRes shaRes $ \cur sha -> do
+  combineErrorM curRes mRes $ \cur compiled -> do
+    res <- liftExcept $ shadowMatches compiled tx
     let es = entryPair stFrom stTo cur stDesc stRatio ()
-    return $ if not sha then Nothing else Just es
+    return $ if not res then Nothing else Just es
   where
-    curRes = lookupCurrencyKey (CurID stCurrency)
-    shaRes = liftExcept $ shadowMatches stMatch tx
+    curRes = lookupCurrencyKey stCurrency
+    mRes = liftExcept $ compileMatch stMatch
 
-shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
+shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
+shadowMatches
+  TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
+  Tx {txPrimary, txMeta = TxMeta {txmDate}} =
+    do
+      -- ASSUME these will never fail and thus I don't need to worry about
+      -- stacking the errors
+      fromRes <- acntMatches fa tmFrom
+      toRes <- acntMatches ta tmTo
       -- NOTE this will only match against the primary entry set since those
       -- are what are guaranteed to exist from a transfer
       valRes <- case txPrimary of
         Left es -> valMatches tmVal $ toRational $ esTotalValue es
         Right _ -> return True
       return $
-    memberMaybe fa tmFrom
-      && memberMaybe ta tmTo
-      && maybe True (`dateMatches` txDate) tmDate
+        fromRes
+          && toRes
+          && maybe True (`dateMatches` txmDate) tmDate
           && valRes
     where
       fa = either getAcntFrom getAcntFrom txPrimary
@@ -372,8 +378,22 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
       getAcntFrom = getAcnt esFrom
       getAcntTo = getAcnt esTo
       getAcnt f = eAcnt . hesPrimary . f
-    memberMaybe x AcntSet {asList, asInclude} =
-      (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
+      acntMatches (AcntID a) = maybe (return True) (match' a)
+      match' a AcntMatcher_ {amPat, amInvert} =
+        (if amInvert then not else id) <$> matchMaybe a amPat
+
+compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
+compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
+  combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
+  where
+    go a@AcntMatcher_ {amPat} = do
+      (_, p) <- compileRegex False amPat
+      return $ a {amPat = p}
+    tres = mapM go tmTo
+    fres = mapM go tmFrom
+
+-- memberMaybe x AcntSet {asList, asInclude} =
+--   (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
 
 --------------------------------------------------------------------------------
 -- random

lib/Internal/Database.hs

@@ -1,8 +1,9 @@
 module Internal.Database
   ( runDB
-  , readConfigState
+  , readDB
   , nukeTables
-  , updateDBState
+  , updateMeta
+  -- , updateDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -10,16 +11,18 @@ module Internal.Database
   , mkPool
   , insertEntry
   , readUpdates
-  , insertAll
   , updateTx
+  , sync
   )
 where
 
 import Conduit
 import Control.Monad.Except
+import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
+import qualified Data.Text.IO as TI
 import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
@@ -36,16 +39,84 @@ import Database.Persist.Sqlite hiding
   , (==.)
   , (||.)
   )
-import GHC.Err
+import Internal.Budget
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
-import RIO hiding (LogFunc, isNothing, on, (^.))
+import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Set as S
 import qualified RIO.Text as T
 
+sync
+  :: (MonadUnliftIO m, MonadRerunnableIO m)
+  => ConnectionPool
+  -> FilePath
+  -> Config
+  -> [Budget]
+  -> [History]
+  -> m ()
+sync pool root c bs hs = do
+  -- _ <- askLoggerIO
+
+  (meta, txState, budgets, history) <- runSqlQueryT pool $ do
+    runMigration migrateAll
+    liftIOExceptT $ readDB c bs hs
+
+  -- Read raw transactions according to state. If a transaction is already in
+  -- the database, don't read it but record the commit so we can update it.
+  (budgets', history') <-
+    flip runReaderT txState $ do
+      -- TODO collect errors here
+      b <- liftIOExceptT $ readBudgetCRUD budgets
+      h <- readHistoryCRUD root history
+      return (b, h)
+  liftIO $ TI.putStr $ formatBuildPlan history budgets
+
+  -- Update the DB.
+  runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
+    -- NOTE this must come first (unless we defer foreign keys)
+    updateMeta meta
+    res <- runExceptT $ do
+      -- TODO multithread this :)
+      insertBudgets budgets'
+      insertHistory history'
+    -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
+    -- whatever error is encountered above in an IO context, but the first
+    -- thrown error should be caught despite possibly needing to be rerun
+    rerunnableIO $ fromEither res
+
+formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
+formatBuildPlan
+  CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
+  CRUDOps {coCreate = bc, coDelete = bd} =
+    T.unlines $ "Build plan:" : (T.append "  " <$> ht ++ [""] ++ bt)
+    where
+      ht =
+        [ T.append "History transfers to create: " $ tshow hCt
+        , T.append "History statements to create: " $ tshow hCs
+        , T.append "History entries to read: " $ tshow $ length hr
+        , T.append "History entry sets to update: " $ tshow $ length hu
+        ]
+          ++ formatDel "History" hd
+      bt =
+        T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
+          : formatDel "Budget" bd
+      toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
+      formatDel what (DeleteTxs e a b c' d) =
+        [ f "commits" e
+        , f "transactions" a
+        , f "entry sets" b
+        , f "entries" c'
+        , f "tag relations" d
+        ]
+        where
+          f :: T.Text -> [a] -> T.Text
+          f thing = toDel what thing . length
+      (hCt, hCs) = bimap length length hc
+
 runDB
   :: MonadUnliftIO m
   => SqlConfig
@@ -106,58 +177,116 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
-readConfigState
+readDB
   :: (MonadAppError m, MonadSqlQuery m)
   => Config
   -> [Budget]
   -> [History]
-  -> m ConfigState
-readConfigState c bs hs = do
-  (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
-  (pathsIns, _, pathsDel) <- diff newPaths
-  (curs2Ins, cursRem, curs2Del) <- diff newCurs
-  (tags2Ins, tagsRem, tags2Del) <- diff newTags
-  let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
-  let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
-  let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
-  let fromMap f = S.fromList . fmap f . M.elems
-  let existing =
-        ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
-
+  -> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
+readDB c bs hs = do
+  curAcnts <- readCurrentIds
+  curPaths <- readCurrentIds
+  curCurs <- readCurrentIds
+  curTags <- readCurrentIds
   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-  -- TODO refine this test to include the whole db (with data already mixed
-  -- in this algorithm)
   let bsRes = BudgetSpan <$> resolveScope budgetInterval
   let hsRes = HistorySpan <$> resolveScope statementInterval
   combineErrorM bsRes hsRes $ \bscope hscope -> do
-    let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
-    (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
-    bgt <- makeTxCRUD existing bs curBgts bChanged
-    hTrans <- makeTxCRUD existing ts curHistTrs hChanged
-    hStmt <- makeTxCRUD existing ss curHistSts hChanged
-
-    return $
-      ConfigState
-        { csCurrencies = CRUDOps curs2Ins () () curs2Del
-        , csTags = CRUDOps tags2Ins () () tags2Del
-        , csAccounts = CRUDOps acnts2Ins () () acnts2Del
-        , csPaths = CRUDOps pathsIns () () pathsDel
-        , csBudgets = bgt
-        , csHistTrans = hTrans
-        , csHistStmts = hStmt
-        , csAccountMap = amap
-        , csCurrencyMap = cmap
-        , csTagMap = tmap
-        , csBudgetScope = bscope
-        , csHistoryScope = hscope
+    -- ASSUME the db must be empty if these are empty
+    let dbempty = null curAcnts && null curCurs && null curTags
+    let meta =
+          MetaCRUD
+            { mcCurrencies = makeCD newCurs curCurs
+            , mcTags = makeCD newTags curTags
+            , mcAccounts = makeCD newAcnts curAcnts
+            , mcPaths = makeCD newPaths curPaths
+            , mcBudgetScope = bscope
+            , mcHistoryScope = hscope
             }
+    let txS =
+          TxState
+            { tsAccountMap = amap
+            , tsCurrencyMap = cmap
+            , tsTagMap = tmap
+            , tsBudgetScope = bscope
+            , tsHistoryScope = hscope
+            }
+    (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
+    budgets <- makeBudgetCRUD existing bs curBgts bChanged
+    history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
+    return (meta, txS, budgets, history)
   where
     (ts, ss) = splitHistory hs
-    diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
+    makeCD new old =
+      let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
+       in CRUDOps cs () () ds
     (newAcnts, newPaths) = indexAcntRoot $ accounts c
     newTags = tag2Record <$> tags c
     newCurs = currency2Record <$> currencies c
     resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
+    amap = makeAcntMap newAcnts
+    cmap = currencyMap newCurs
+    tmap = makeTagMap newTags
+    fromMap f = S.fromList . fmap f . M.elems
+    existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
+
+makeBudgetCRUD
+  :: MonadSqlQuery m
+  => ExistingConfig
+  -> [Budget]
+  -> [CommitHash]
+  -> Bool
+  -> m (CRUDOps [Budget] () () DeleteTxs)
+makeBudgetCRUD existing new old scopeChanged = do
+  (toIns, toDel) <-
+    if scopeChanged
+      then (new,) <$> readTxIds old
+      else do
+        let (toDelHashes, overlap, toIns) = setDiffHashes old new
+        toDel <- readTxIds toDelHashes
+        (toInsRetry, _) <- readInvalidIds existing overlap
+        return (toIns ++ (snd <$> toInsRetry), toDel)
+  return $ CRUDOps toIns () () toDel
+
+makeStatementCRUD
+  :: (MonadAppError m, MonadSqlQuery m)
+  => ExistingConfig
+  -> ([PairedTransfer], [CommitHash])
+  -> ([Statement], [CommitHash])
+  -> Bool
+  -> m
+      ( CRUDOps
+          ([PairedTransfer], [Statement])
+          [ReadEntry]
+          [Either TotalUpdateEntrySet FullUpdateEntrySet]
+          DeleteTxs
+      )
+makeStatementCRUD existing ts ss scopeChanged = do
+  (toInsTs, toDelTs, validTs) <- uncurry diff ts
+  (toInsSs, toDelSs, validSs) <- uncurry diff ss
+  let toDelAllHashes = toDelTs ++ toDelSs
+  -- If we are inserting or deleting something or the scope changed, pull out
+  -- the remainder of the entries to update/read as we are (re)inserting other
+  -- stuff (this is necessary because a given transaction may depend on the
+  -- value of previous transactions, even if they are already in the DB).
+  (toRead, toUpdate) <- case (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
+    ([], [], [], False) -> return ([], [])
+    _ -> readUpdates $ validTs ++ validSs
+  toDelAll <- readTxIds toDelAllHashes
+  return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
+  where
+    diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
+    diff new old = do
+      let (toDelHashes, overlap, toIns) = setDiffHashes old new
+      -- Check the overlap for rows with accounts/tags/currencies that
+      -- won't exist on the next update. Those with invalid IDs will be set aside
+      -- to delete and reinsert (which may also fail) later
+      (invalid, valid) <- readInvalidIds existing overlap
+      let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
+      return (toInsAll, toDelAllHashes, valid)
+
+setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
+setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
 
 readScopeChanged
   :: (MonadAppError m, MonadSqlQuery m)
@@ -175,37 +304,6 @@ readScopeChanged dbempty bscope hscope = do
       return (bscope /= b, hscope /= h)
     _ -> throwAppError $ DBError DBMultiScope
 
-makeTxCRUD
-  :: (MonadAppError m, MonadSqlQuery m, Hashable a)
-  => ExistingConfig
-  -> [a]
-  -> [CommitHash]
-  -> Bool
-  -> m
-      ( CRUDOps
-          [a]
-          [ReadEntry]
-          [Either TotalUpdateEntrySet FullUpdateEntrySet]
-          DeleteTxs
-      )
-makeTxCRUD existing newThings curThings scopeChanged = do
-  let (toDelHashes, overlap, toIns) =
-        setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
-  -- Check the overlap for rows with accounts/tags/currencies that
-  -- won't exist on the next update. Those with invalid IDs will be set aside
-  -- to delete and reinsert (which may also fail) later
-  (noRetry, toInsRetry) <- readInvalidIds existing overlap
-  let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-  -- If we are inserting or deleting something or the scope changed, pull out
-  -- the remainder of the entries to update/read as we are (re)inserting other
-  -- stuff (this is necessary because a given transaction may depend on the
-  -- value of previous transactions, even if they are already in the DB).
-  (toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
-    ([], [], False) -> return ([], [])
-    _ -> readUpdates noRetry
-  toDelAll <- readTxIds toDelAllHashes
-  return $ CRUDOps toInsAll toRead toUpdate toDelAll
-
 readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
 readTxIds cs = do
   xs <- selectE $ do
@@ -218,33 +316,29 @@ readTxIds cs = do
         `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table
         `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
+          `E.leftJoin` E.table
+        `E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
     return
-      ( txs ^. TransactionRId
+      ( commits ^. CommitRId
+      , txs ^. TransactionRId
       , ess ^. EntrySetRId
       , es ^. EntryRId
-      , ts ^. TagRelationRId
+      , ts ?. TagRelationRId
       )
-  let (txs, ss, es, ts) = L.unzip4 xs
+  let (cms, txs, ss, es, ts) = L.unzip5 xs
   return $
     DeleteTxs
-      { dtTxs = go txs
+      { dtCommits = go cms
+      , dtTxs = go txs
       , dtEntrySets = go ss
       , dtEntries = go es
-      , dtTagRelations = E.unValue <$> ts
+      , dtTagRelations = catMaybes $ E.unValue <$> ts
       }
   where
     go :: Eq a => [E.Value a] -> [a]
     go = fmap (E.unValue . NE.head) . NE.group
 
-splitHistory :: [History] -> ([PairedTransfer], [Statement])
-splitHistory = partitionEithers . fmap go
-  where
-    go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
-
 makeTagMap :: [Entity TagR] -> TagMap
 makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
@@ -255,7 +349,7 @@ currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
 
-readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
+readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
 readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
   rs <- E.from E.table
   return (rs ^. E.persistIdField)
@@ -263,8 +357,8 @@ readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
 readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
 readCurrentCommits = do
   xs <- selectE $ do
-    rs <- E.from E.table
-    return (rs ^. CommitRHash, rs ^. CommitRType)
+    commits <- E.from E.table
+    return (commits ^. CommitRHash, commits ^. CommitRType)
   return $ foldr go ([], [], []) xs
   where
     go (x, t) (bs, ts, hs) =
@@ -387,39 +481,55 @@ indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . fl
 updateCD
   :: ( MonadSqlQuery m
      , PersistRecordBackend a SqlBackend
-     , PersistRecordBackend b SqlBackend
      )
-  => CDOps (Entity a) (Key b)
+  => EntityCRUDOps a
   -> m ()
 updateCD (CRUDOps cs () () ds) = do
   mapM_ deleteKeyE ds
   insertEntityManyE cs
 
+-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
 deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
-deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
-  mapM_ deleteKeyE dtTxs
-  mapM_ deleteKeyE dtEntrySets
-  mapM_ deleteKeyE dtEntries
+deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
   mapM_ deleteKeyE dtTagRelations
+  mapM_ deleteKeyE dtEntries
+  mapM_ deleteKeyE dtEntrySets
+  mapM_ deleteKeyE dtTxs
+  mapM_ deleteKeyE dtCommits
 
-updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
-updateDBState = do
-  updateCD =<< asks csCurrencies
-  updateCD =<< asks csAccounts
-  updateCD =<< asks csPaths
-  updateCD =<< asks csTags
-  deleteTxs =<< asks (coDelete . csBudgets)
-  deleteTxs =<< asks (coDelete . csHistTrans)
-  deleteTxs =<< asks (coDelete . csHistStmts)
-  b <- asks csBudgetScope
-  h <- asks csHistoryScope
-  repsertE (E.toSqlKey 1) $ ConfigStateR h b
+-- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+-- updateDBState = do
+--   updateCD =<< asks csCurrencies
+--   updateCD =<< asks csAccounts
+--   updateCD =<< asks csPaths
+--   updateCD =<< asks csTags
+--   -- deleteTxs =<< asks (coDelete . csBudgets)
+--   -- deleteTxs =<< asks (coDelete . csHistory)
+--   b <- asks csBudgetScope
+--   h <- asks csHistoryScope
+--   repsertE (E.toSqlKey 1) $ ConfigStateR h b
+
+updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
+updateMeta
+  MetaCRUD
+    { mcCurrencies
+    , mcAccounts
+    , mcPaths
+    , mcTags
+    , mcBudgetScope
+    , mcHistoryScope
+    } = do
+    updateCD mcCurrencies
+    updateCD mcAccounts
+    updateCD mcPaths
+    updateCD mcTags
+    repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
 
 readInvalidIds
   :: MonadSqlQuery m
   => ExistingConfig
   -> [(CommitHash, a)]
-  -> m ([CommitHash], [(CommitHash, a)])
+  -> m ([(CommitHash, a)], [CommitHash])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
     (commits :& _ :& entrysets :& entries :& tags) <-
@@ -444,14 +554,13 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
   let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
   let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
-  let valid = (cs `S.intersection` as) `S.intersection` ts
-  let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
-  return (a0, [])
+  let invalid = (cs `S.union` as) `S.union` ts
+  return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
   where
     go existing =
       S.fromList
         . fmap (E.unValue . fst)
-        . L.filter (all (`S.member` existing) . snd)
+        . L.filter (not . all (`S.member` existing) . snd)
         . groupKey id
 
 readUpdates
@@ -477,9 +586,10 @@ readUpdates hashes = do
       ,
         (
           ( entrysets ^. EntrySetRId
+          , entrysets ^. EntrySetRIndex
           , txs ^. TransactionRDate
-          , txs ^. TransactionRBudgetName
           , txs ^. TransactionRPriority
+          , txs ^. TransactionRDescription
           ,
             ( entrysets ^. EntrySetRCurrency
             , currencies ^. CurrencyRPrecision
@@ -489,11 +599,12 @@ readUpdates hashes = do
         )
       )
   let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
-  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
+  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
   let toRead' = fmap (makeRE . snd) toRead
   return (toRead', toUpdate')
   where
-    makeUES ((_, day, name, pri, (curID, prec)), es) = do
+    makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
+      let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
       let prec' = fromIntegral $ E.unValue prec
       let cur = E.unValue curID
       let res =
@@ -511,8 +622,7 @@ readUpdates hashes = do
             Left x ->
               Left $
                 UpdateEntrySet
-                  { utDate = E.unValue day
-                  , utCurrency = cur
+                  { utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -520,14 +630,13 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = realFracToDecimalP prec' tot
-                  , utBudget = E.unValue name
-                  , utPriority = E.unValue pri
+                  , utSortKey = sk
+                  , utIndex = E.unValue esi
                   }
             Right x ->
               Right $
                 UpdateEntrySet
-                  { utDate = E.unValue day
-                  , utCurrency = cur
+                  { utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -535,20 +644,20 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = ()
-                  , utBudget = E.unValue name
-                  , utPriority = E.unValue pri
+                  , utSortKey = sk
+                  , utIndex = E.unValue esi
                   }
         -- TODO this error is lame
-        _ -> throwAppError $ DBError $ DBUpdateUnbalanced
-    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
+        _ -> throwAppError $ DBError DBUpdateUnbalanced
+    makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
-            { reDate = E.unValue day
-            , reCurrency = E.unValue curID
+            { reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
             , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
-            , reBudget = E.unValue name
-            , rePriority = E.unValue pri
+            , reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
+            , reESIndex = E.unValue esi
+            , reIndex = entryRIndex e
             }
 
 splitFrom
@@ -665,8 +774,8 @@ readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) o
   (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   (Just v, Nothing) -> err $ DBLinkInvalidValue v False
   (Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
-  (Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
-  (Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
+  (Nothing, Just TBalance) -> err DBLinkInvalidBalance
+  (Nothing, Just TPercent) -> err DBLinkInvalidPercent
   where
     go = return . Right . Right
     err = throwAppError . DBError . DBLinkError k
@@ -680,21 +789,72 @@ makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRVal
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
 
-insertAll
+-- updateEntries
+--   :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
+--   => [ ( BudgetName
+--        , CRUDOps
+--           [Tx CommitR]
+--           [ReadEntry]
+--           [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
+--           DeleteTxs
+--        )
+--      ]
+--   -> m ()
+-- updateEntries es = do
+--   res <- runExceptT $ mapErrors (uncurry insertAll) es
+--   void $ rerunnableIO $ fromEither res
+
+insertBudgets
   :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryCRU]
+  => FinalBudgetCRUD
   -> m ()
-insertAll ebs = do
-  (toUpdate, toInsert) <- balanceTxs ebs
+insertBudgets (CRUDOps bs () () ds) = do
+  deleteTxs ds
+  mapM_ go bs
+  where
+    go (name, cs) = do
+      -- TODO useless overhead?
+      (toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
       mapM_ updateTx toUpdate
-  forM_ (groupWith itxCommit toInsert) $
+      forM_ (groupWith (txmCommit . itxMeta) toInsert) $
         \(c, ts) -> do
           ck <- insert c
-      mapM_ (insertTx ck) ts
+          mapM_ (insertTx name ck) ts
 
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
-  k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
+insertHistory
+  :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
+  => FinalHistoryCRUD
+  -> m ()
+insertHistory (CRUDOps cs rs us ds) = do
+  (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
+  mapM_ updateTx toUpdate
+  forM_ (groupWith (txmCommit . itxMeta) toInsert) $
+    \(c, ts) -> do
+      ck <- insert c
+      mapM_ (insertTx historyName ck) ts
+  deleteTxs ds
+
+-- insertAll
+--   :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
+--   => BudgetName
+--   -> CRUDOps
+--       [Tx CommitR]
+--       [ReadEntry]
+--       [Either TotalUpdateEntrySet FullUpdateEntrySet]
+--       DeleteTxs
+--   -> m ()
+-- insertAll b (CRUDOps cs rs us ds) = do
+--   (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
+--   mapM_ updateTx toUpdate
+--   forM_ (groupWith itxCommit toInsert) $
+--     \(c, ts) -> do
+--       ck <- insert c
+--       mapM_ (insertTx b ck) ts
+--   deleteTxs ds
+
+insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
+insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
+  k <- insert $ TransactionR c txmDate b txmDesc txmPriority
   mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
@@ -740,3 +900,6 @@ deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
 
 insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
 insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
+
+historyName :: BudgetName
+historyName = BudgetName "history"

lib/Internal/History.hs

@@ -2,6 +2,7 @@ module Internal.History
   ( readHistStmt
   , readHistTransfer
   , splitHistory
+  , readHistoryCRUD
   )
 where
 
@@ -22,7 +23,20 @@ import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 import Text.Regex.TDFA hiding (matchAll)
-import Text.Regex.TDFA.Text
+
+readHistoryCRUD
+  :: (MonadUnliftIO m, MonadFinance m)
+  => FilePath
+  -> PreHistoryCRUD
+  -> m FinalHistoryCRUD
+readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
+  -- TODO multithread this for some extra fun :)
+
+  ss' <- mapErrorsIO (readHistStmt root) ss
+  fromEitherM $ runExceptT $ do
+    let sRes = mapErrors (ExceptT . return) ss'
+    let tRes = mapErrors readHistTransfer ts
+    combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
 
 -- NOTE keep statement and transfer readers separate because the former needs
 -- the IO monad, and thus will throw IO errors rather than using the ExceptT
@@ -41,8 +55,8 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- asks (unHSpan . csHistoryScope)
-  expandTransfer c historyName bounds ht
+  bounds <- asks (unHSpan . tsHistoryScope)
+  expandTransfer c bounds ht
   where
     c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
 
@@ -53,23 +67,28 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m [Tx CommitR]
+  -> m (Either AppException [Tx CommitR])
 readHistStmt root i = do
+  bounds <- asks (unHSpan . tsHistoryScope)
   bs <- readImport root i
-  bounds <- asks (unHSpan . csHistoryScope)
-  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
+  return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
   where
-    c = CommitR (CommitHash $ hash i) CTHistoryStatement
+    go t@Tx {txMeta = m} =
+      t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
+readImport
+  :: (MonadUnliftIO m, MonadFinance m)
+  => FilePath
+  -> Statement
+  -> m (Either AppException [Tx ()])
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
   records <- L.sort . concat <$> mapErrorsIO readStmt paths
-  fromEither =<< runExceptT (matchRecords compiledMatches records)
+  runExceptT (matchRecords compiledMatches records)
   where
     paths = (root </>) <$> stmtPaths
 
@@ -93,39 +112,93 @@ readImport_ n delim tns p = do
 -- TODO handle this better, this maybe thing is a hack to skip lines with
 -- blank dates but will likely want to make this more flexible
 parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
-  d <- r .: T.encodeUtf8 toDate
-  if d == ""
+parseTxRecord
+  p
+  TxOpts
+    { toDate
+    , toDesc
+    , toAmount
+    , toOther
+    , toDateFmt
+    , toSkipBlankDate
+    , toSkipBlankAmount
+    , toSkipBlankDescription
+    , toSkipBlankOther
+    , toSkipMissingFields
+    }
+  r =
+    do
+      -- TODO this is confusing as hell
+      --
+      -- try and parse all fields; if a parse fails, either trip an error
+      -- or return a Nothing if we want to deliberately skip missing fields
+      d <- getField toDate
+      e <- getField toDesc
+      os <-
+        fmap M.fromList . sequence
+          <$> mapM (\n -> fmap (n,) <$> getField n) toOther
+      (af, ax) <- case toAmount of
+        -- the amount column is extra confusing because it can either be one
+        -- or two columns, so keep track of this with a maybe
+        AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
+          f <- getField a1Column
+          return (a1Fmt, Right <$> f)
+        AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
+          f1 <- getField a2Positive
+          f2 <- getField a2Negative
+          return $ (a2Fmt,) $ case (f1, f2) of
+            (Just a, Just b) -> Just $ Left (a, b)
+            _ -> Nothing
+      case (d, e, os, ax) of
+        -- If all lookups were successful, check that none of the fields are
+        -- blank, and if they are return nothing to skip this line
+        (Just d', Just e', Just os', Just ax') ->
+          if (toSkipBlankDate && d' == "")
+            || (toSkipBlankDescription && e' == "")
+            || (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
+            || elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
             then return Nothing
-    else do
-      a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
-      e <- r .: T.encodeUtf8 toDesc
-      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
-      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
-      return $ Just $ TxRecord d' a e os p
+            else -- if we are skipping nothing, proceed to parse the date and amount
+            -- columns
+            do
+              a <- case ax' of
+                Right a -> parseDecimal True af a
+                Left ("", a) -> ((-1) *) <$> parseDecimal False af a
+                Left (a, _) -> parseDecimal False af a
+              d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
+              return $ Just $ TxRecord d'' a e' os' p
+        -- if no lookups succeeded, return nothing to skip this line. Note that
+        -- a parse fail will trigger a failure error further up, so that case
+        -- is already dealt with implicitly
+        _ -> return Nothing
+    where
+      getField :: FromField a => T.Text -> Parser (Maybe a)
+      getField f = case runParser $ r .: T.encodeUtf8 f of
+        Left err -> if toSkipMissingFields then return Nothing else fail err
+        Right x -> return $ Just x
 
-matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
+matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
     (ms_, [], []) -> return ms_
     (_, us, ns) -> throwError $ AppException [StatementError us ns]
 
-matchPriorities :: [MatchRe] -> [MatchGroup]
+matchPriorities :: [StatementParserRe] -> [MatchGroup]
 matchPriorities =
   fmap matchToGroup
     . L.groupBy (\a b -> spPriority a == spPriority b)
     . L.sortOn (Down . spPriority)
 
-matchToGroup :: [MatchRe] -> MatchGroup
+matchToGroup :: [StatementParserRe] -> MatchGroup
 matchToGroup ms =
   uncurry MatchGroup $
     first (L.sortOn spDate) $
       L.partition (isJust . spDate) ms
 
 data MatchGroup = MatchGroup
-  { mgDate :: ![MatchRe]
-  , mgNoDate :: ![MatchRe]
+  { mgDate :: ![StatementParserRe]
+  , mgNoDate :: ![StatementParserRe]
   }
   deriving (Show)
 
@@ -164,9 +237,9 @@ zipperSlice f x = go
 
 zipperMatch
   :: MonadFinance m
-  => Unzipped MatchRe
+  => Unzipped StatementParserRe
   -> TxRecord
-  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -181,9 +254,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
 
 zipperMatch'
   :: MonadFinance m
-  => Zipped MatchRe
+  => Zipped StatementParserRe
   -> TxRecord
-  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -194,7 +267,7 @@ zipperMatch' z x = go z
           return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
     go z' = return (z', MatchFail)
 
-matchDec :: MatchRe -> Maybe MatchRe
+matchDec :: StatementParserRe -> Maybe StatementParserRe
 matchDec m = case spTimes m of
   Just 1 -> Nothing
   Just n -> Just $ m {spTimes = Just $ n - 1}
@@ -204,7 +277,7 @@ matchAll
   :: MonadFinance m
   => [MatchGroup]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -218,7 +291,7 @@ matchGroup
   :: MonadFinance m
   => MatchGroup
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
@@ -226,9 +299,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
 
 matchDates
   :: MonadFinance m
-  => [MatchRe]
+  => [StatementParserRe]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -251,9 +324,9 @@ matchDates ms = go ([], [], initZipper ms)
 
 matchNonDates
   :: MonadFinance m
-  => [MatchRe]
+  => [StatementParserRe]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -270,7 +343,11 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
+matches
+  :: MonadFinance m
+  => StatementParserRe
+  -> TxRecord
+  -> AppExceptT m (MatchRes (Tx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -300,9 +377,7 @@ toTx
   r@TxRecord {trAmount, trDate, trDesc} = do
     combineError curRes subRes $ \(cur, f, t) ss ->
       Tx
-        { txDate = trDate
-        , txDescr = trDesc
-        , txCommit = ()
+        { txMeta = TxMeta trDate priority trDesc ()
         , txPrimary =
             Left $
               EntrySet
@@ -312,12 +387,10 @@ toTx
                 , esTo = t
                 }
         , txOther = Left <$> ss
-        , txBudget = historyName
-        , txPriority = priority
         }
     where
       curRes = do
-        m <- asks csCurrencyMap
+        m <- asks tsCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -331,7 +404,7 @@ resolveSubGetter
   -> TxSubGetter
   -> AppExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- asks csCurrencyMap
+  m <- asks tsCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@@ -449,11 +522,17 @@ readRational s = case T.split (== '.') s of
     err = throwError $ AppException [ConversionError s False]
 
 compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
-compileOptions o@TxOpts {toAmountFmt = pat} = do
-  re <- compileRegex True pat
-  return $ o {toAmountFmt = re}
+compileOptions = mapM (compileRegex True)
 
-compileMatch :: StatementParser T.Text -> AppExcept MatchRe
+-- compileOptions o@TxOpts {toAmount = pat} = case pat of
+--   AmountSingle (TxAmount1 {a1Fmt}) -> do
+--     re <- compileRegex True a1Fmt
+--     return $ o {toAmountFmt = re}
+--   AmountDual (TxAmount2 {a2Fmt}) -> do
+--     re <- compileRegex True a2Fmt
+--     return $ o {toAmountFmt = re}
+
+compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
 compileMatch m@StatementParser {spDesc, spOther} = do
   combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
   where
@@ -461,42 +540,15 @@ compileMatch m@StatementParser {spDesc, spOther} = do
     dres = mapM go spDesc
     ores = combineErrors $ fmap (mapM go) spOther
 
-compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
-compileRegex groups pat = case res of
-  Right re -> return (pat, re)
-  Left _ -> throwError $ AppException [RegexError pat]
-  where
-    res =
-      compile
-        (blankCompOpt {newSyntax = True})
-        (blankExecOpt {captureGroups = groups})
-        pat
-
-matchMaybe :: T.Text -> Regex -> AppExcept Bool
-matchMaybe q re = case execute re q of
-  Right res -> return $ isJust res
-  Left _ -> throwError $ AppException [RegexError "this should not happen"]
-
-matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
-matchGroupsMaybe q re = case regexec re q of
-  Right Nothing -> []
-  Right (Just (_, _, _, xs)) -> xs
-  -- this should never fail as regexec always returns Right
-  Left _ -> []
-
-parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
-parseDecimal (pat, re) s = case matchGroupsMaybe s re of
-  [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
-  [sign, x, y] -> do
-    d <- readT "decimal" y
-    let p = T.length y
-    (k, w) <- readWhole sign x
-    return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
+parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
+parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
+  (True, [sign, num]) -> do
+    k <- readSign sign
+    x <- readNum num
+    return $ k * x
+  (False, [num]) -> readNum num
   _ -> msg "malformed decimal"
   where
-    readT what t = case readMaybe $ T.unpack t of
-      Just d -> return $ fromInteger d
-      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
     msg :: MonadFail m => T.Text -> m a
     msg m =
       fail $
@@ -506,10 +558,10 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
       | x == "-" = return (-1)
       | x == "+" || x == "" = return 1
       | otherwise = msg $ T.append "invalid sign: " x
-    readWhole sign x = do
-      w <- readT "whole number" x
-      k <- readSign sign
-      return (k, w)
-
-historyName :: BudgetName
-historyName = BudgetName "history"
+    readNum x =
+      maybe
+        (msg $ T.unwords ["could not parse", singleQuote x])
+        return
+        $ readMaybe
+        $ T.unpack
+        $ T.filter (/= ',') x

lib/Internal/Types/Database.hs

@@ -24,10 +24,12 @@ CommitR sql=commits
     type ConfigType
     UniqueCommitHash hash
     deriving Show Eq Ord
+
 ConfigStateR sql=config_state
     historySpan HistorySpan
     budgetSpan BudgetSpan
     deriving Show
+
 CurrencyR sql=currencies
     symbol CurID
     fullname T.Text
@@ -35,12 +37,14 @@ CurrencyR sql=currencies
     UniqueCurrencySymbol symbol
     UniqueCurrencyFullname fullname
     deriving Show Eq Ord
+
 TagR sql=tags
     symbol TagID
     fullname T.Text
     UniqueTagSymbol symbol
     UniqueTagFullname fullname
     deriving Show Eq Ord
+
 AccountR sql=accounts
     name T.Text
     fullpath AcntPath
@@ -49,24 +53,28 @@ AccountR sql=accounts
     leaf Bool
     UniqueAccountFullpath fullpath
     deriving Show Eq Ord
+
 AccountPathR sql=account_paths
     parent AccountRId 
     child AccountRId 
     depth Int
     deriving Show Eq Ord
+
 TransactionR sql=transactions
     commit CommitRId 
     date Day
-    description TxDesc
     budgetName BudgetName
+    description TxDesc
     priority Int
     deriving Show Eq
+
 EntrySetR sql=entry_sets
     transaction TransactionRId 
     currency CurrencyRId 
     index EntrySetIndex
     rebalance Bool
     deriving Show Eq
+
 EntryR sql=entries
     entryset EntrySetRId  
     account AccountRId 
@@ -77,12 +85,16 @@ EntryR sql=entries
     cachedType (Maybe TransferType)
     cachedLink (Maybe EntryIndex)
     deriving Show Eq
+
 TagRelationR sql=tag_relations
     entry EntryRId 
     tag TagRId
     deriving Show Eq
 |]
 
+newtype TxIndex = TxIndex {unTxIndex :: Int}
+  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
+
 newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
   deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
 
@@ -90,7 +102,7 @@ newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
   deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
 
 newtype TxDesc = TxDesc {unTxDesc :: T.Text}
-  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
+  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
 
 newtype Precision = Precision {unPrecision :: Word8}
   deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)

lib/Internal/Types/Dhall.hs

@@ -49,17 +49,16 @@ makeHaskellTypesWith
   , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
   , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
   , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
+  , SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
+  , SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
   , SingleConstructor
       "Amount"
       "Amount"
       "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
   , SingleConstructor
-      "TxOpts"
-      "TxOpts"
-      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
-  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
-  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
-  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
+      "AcntMatcher_"
+      "AcntMatcher_"
+      "\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
   , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
   , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
   , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@@ -88,11 +87,7 @@ deriveProduct
   , "CronPat"
   , "DatePat"
   , "TaggedAcnt"
-  , "Budget"
   , "Income"
-  , "ShadowTransfer"
-  , "TransferMatcher"
-  , "AcntSet"
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
@@ -191,15 +186,33 @@ newtype BudgetName = BudgetName {unBudgetName :: T.Text}
   deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
 
 data Budget = Budget
-  { bgtLabel :: BudgetName
-  , bgtIncomes :: [Income]
-  , bgtPretax :: [MultiAllocation PretaxValue]
-  , bgtTax :: [MultiAllocation TaxValue]
-  , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: [PairedTransfer]
-  , bgtShadowTransfers :: [ShadowTransfer]
+  { bgtLabel :: !BudgetName
+  , bgtIncomes :: ![Income]
+  , bgtPretax :: ![MultiAllocation PretaxValue]
+  , bgtTax :: ![MultiAllocation TaxValue]
+  , bgtPosttax :: ![MultiAllocation PosttaxValue]
+  , bgtTransfers :: ![PairedTransfer]
+  , bgtShadowTransfers :: ![ShadowTransfer]
   , bgtInterval :: !(Maybe Interval)
   }
+  deriving (Generic, Hashable, FromDhall)
+
+data ShadowTransfer = ShadowTransfer
+  { stFrom :: !TaggedAcnt
+  , stTo :: !TaggedAcnt
+  , stCurrency :: !CurID
+  , stDesc :: !Text
+  , stMatch :: !(TransferMatcher_ Text)
+  , stRatio :: !Double
+  }
+  deriving (Generic, Hashable, FromDhall)
+
+data TransferMatcher_ re = TransferMatcher_
+  { tmFrom :: !(Maybe (AcntMatcher_ re))
+  , tmTo :: !(Maybe (AcntMatcher_ re))
+  , tmDate :: !(Maybe DateMatcher)
+  , tmVal :: !ValMatcher
+  }
 
 deriving instance Hashable PretaxValue
 
@@ -213,8 +226,6 @@ deriving instance Hashable TaxValue
 
 deriving instance Hashable PosttaxValue
 
-deriving instance Hashable Budget
-
 deriving instance Hashable TransferValue
 
 deriving instance Hashable TransferType
@@ -314,11 +325,17 @@ data Transfer a c w v = Transfer
   }
   deriving (Eq, Show)
 
-deriving instance Hashable ShadowTransfer
+deriving instance Generic (TransferMatcher_ Text)
 
-deriving instance Hashable AcntSet
+deriving instance Hashable (TransferMatcher_ Text)
 
-deriving instance Hashable TransferMatcher
+deriving instance FromDhall (TransferMatcher_ Text)
+
+deriving instance Generic (AcntMatcher_ Text)
+
+deriving instance Hashable (AcntMatcher_ Text)
+
+deriving instance FromDhall (AcntMatcher_ Text)
 
 deriving instance Hashable ValMatcher
 
@@ -449,12 +466,44 @@ deriving instance Eq a => Eq (TxOpts a)
 
 deriving instance Generic (TxOpts a)
 
-deriving instance Hashable a => Hashable (TxOpts a)
+deriving instance Hashable (TxOpts T.Text)
 
-deriving instance FromDhall a => FromDhall (TxOpts a)
+deriving instance FromDhall (TxOpts T.Text)
 
 deriving instance Show a => Show (TxOpts a)
 
+deriving instance Eq re => Eq (TxAmount1 re)
+
+deriving instance Eq re => Eq (TxAmount2 re)
+
+deriving instance Show re => Show (TxAmount1 re)
+
+deriving instance Show re => Show (TxAmount2 re)
+
+deriving instance Generic (TxAmount1 T.Text)
+
+deriving instance Generic (TxAmount2 T.Text)
+
+deriving instance Hashable (TxAmount1 T.Text)
+
+deriving instance Hashable (TxAmount2 T.Text)
+
+deriving instance FromDhall (TxAmount1 T.Text)
+
+deriving instance FromDhall (TxAmount2 T.Text)
+
+deriving instance Functor TxAmount1
+
+deriving instance Functor TxAmount2
+
+deriving instance Foldable TxAmount1
+
+deriving instance Foldable TxAmount2
+
+deriving instance Traversable TxAmount1
+
+deriving instance Traversable TxAmount2
+
 data Statement = Statement
   { stmtPaths :: ![FilePath]
   , stmtParsers :: ![StatementParser T.Text]
@@ -464,6 +513,29 @@ data Statement = Statement
   }
   deriving (Eq, Hashable, Generic, FromDhall, Show)
 
+data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+deriving instance Generic (TxAmountSpec T.Text)
+
+deriving instance FromDhall (TxAmountSpec T.Text)
+
+deriving instance Hashable (TxAmountSpec T.Text)
+
+data TxOpts re = TxOpts
+  { toDate :: !T.Text
+  , toAmount :: !(TxAmountSpec re)
+  , toDesc :: !T.Text
+  , toOther :: ![T.Text]
+  , toDateFmt :: !T.Text
+  , toSkipBlankDate :: !Bool
+  , toSkipBlankAmount :: !Bool
+  , toSkipBlankDescription :: !Bool
+  , toSkipBlankOther :: ![Text]
+  , toSkipMissingFields :: !Bool
+  }
+  deriving (Functor, Foldable, Traversable)
+
 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value

lib/Internal/Types/Main.hs

@@ -26,32 +26,51 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types
 
-type MonadFinance = MonadReader ConfigState
+type MonadFinance = MonadReader TxState
 
 data DeleteTxs = DeleteTxs
-  { dtTxs :: ![TransactionRId]
+  { dtCommits :: ![CommitRId]
+  , dtTxs :: ![TransactionRId]
   , dtEntrySets :: ![EntrySetRId]
   , dtEntries :: ![EntryRId]
   , dtTagRelations :: ![TagRelationRId]
   }
   deriving (Show)
 
-type CDOps c d = CRUDOps [c] () () [d]
+type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
 
--- TODO split the entry stuff from the account metadata stuff
-data ConfigState = ConfigState
-  { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
-  , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
-  , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
-  , csTags :: !(CDOps (Entity TagR) TagRId)
-  , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csAccountMap :: !AccountMap
-  , csCurrencyMap :: !CurrencyMap
-  , csTagMap :: !TagMap
-  , csBudgetScope :: !BudgetSpan
-  , csHistoryScope :: !HistorySpan
+data MetaCRUD = MetaCRUD
+  { mcCurrencies :: !(EntityCRUDOps CurrencyR)
+  , mcAccounts :: !(EntityCRUDOps AccountR)
+  , mcPaths :: !(EntityCRUDOps AccountPathR)
+  , mcTags :: !(EntityCRUDOps TagR)
+  , mcBudgetScope :: !BudgetSpan
+  , mcHistoryScope :: !HistorySpan
+  }
+
+type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
+
+type PreBudgetCRUD = BudgetCRUDOps Budget
+
+type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
+
+type HistoryCRUDOps h =
+  CRUDOps
+    h
+    [ReadEntry]
+    [Either TotalUpdateEntrySet FullUpdateEntrySet]
+    DeleteTxs
+
+type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
+
+type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
+
+data TxState = TxState
+  { tsAccountMap :: !AccountMap
+  , tsCurrencyMap :: !CurrencyMap
+  , tsTagMap :: !TagMap
+  , tsBudgetScope :: !BudgetSpan
+  , tsHistoryScope :: !HistorySpan
   }
   deriving (Show)
 
@@ -83,13 +102,22 @@ data CachedEntry
   | CachedBalance Decimal
   | CachedPercent Double
 
+data TxSortKey = TxSortKey
+  { tskDate :: !Day
+  , tskPriority :: !Int
+  , tskDesc :: !TxDesc
+  }
+  deriving (Show, Eq, Ord)
+
+-- TODO this should actually be a ReadTx since it will be compared with other
+-- Tx's to get the insert/update order correct
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
   , reAcnt :: !AccountRId
   , reValue :: !Decimal
-  , reDate :: !Day
-  , rePriority :: !Int
-  , reBudget :: !BudgetName
+  , reIndex :: !EntryIndex
+  , reESIndex :: !EntrySetIndex
+  , reSortKey :: !TxSortKey
   }
   deriving (Show)
 
@@ -129,10 +157,9 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
-  , utDate :: !Day
   , utTotalValue :: !t
-  , utBudget :: !BudgetName
-  , utPriority :: !Int
+  , utIndex :: !EntrySetIndex
+  , utSortKey :: !TxSortKey
   }
   deriving (Show)
 
@@ -195,14 +222,18 @@ type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
 data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
 
+data TxMeta k = TxMeta
+  { txmDate :: !Day
+  , txmPriority :: !Int
+  , txmDesc :: !TxDesc
+  , txmCommit :: !k
+  }
+  deriving (Show, Eq, Ord)
+
 data Tx k = Tx
-  { txDescr :: !TxDesc
-  , txDate :: !Day
-  , txPriority :: !Int
+  { txMeta :: !(TxMeta k)
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
-  , txCommit :: !k
-  , txBudget :: !BudgetName
   }
   deriving (Generic, Show)
 
@@ -218,12 +249,8 @@ data InsertEntrySet = InsertEntrySet
   }
 
 data InsertTx = InsertTx
-  { itxDescr :: !TxDesc
-  , itxDate :: !Day
-  , itxPriority :: !Int
+  { itxMeta :: !(TxMeta CommitR)
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
-  , itxCommit :: !CommitR
-  , itxBudget :: !BudgetName
   }
   deriving (Generic)
 
@@ -279,7 +306,7 @@ data AppError
   | LookupError !LookupSuberr !T.Text
   | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
-  | StatementError ![TxRecord] ![MatchRe]
+  | StatementError ![TxRecord] ![StatementParserRe]
   | PeriodError !Day !Day
   | LinkError !EntryIndex !EntryIndex
   | DBError !DBSubError
@@ -296,7 +323,9 @@ type AppExceptT = ExceptT AppException
 
 type AppExcept = AppExceptT Identity
 
-type MatchRe = StatementParser (T.Text, Regex)
+type StatementParserRe = StatementParser (T.Text, Regex)
+
+type TransferMatcherRe = TransferMatcher_ Regex
 
 type TxOptsRe = TxOpts (T.Text, Regex)
 

lib/Internal/Utils.hs

@@ -51,6 +51,9 @@ module Internal.Utils
   , keyVals
   , realFracToDecimalP
   , roundToP
+  , compileRegex
+  , matchMaybe
+  , matchGroupsMaybe
   )
 where
 
@@ -69,6 +72,8 @@ import RIO.State
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
+import Text.Regex.TDFA hiding (matchAll)
+import Text.Regex.TDFA.Text
 
 --------------------------------------------------------------------------------
 -- intervals
@@ -125,7 +130,7 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
 
 expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [Natural]
 expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
-expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
+expandMDYPat lower upper (Multi xs) = return $ dropWhile (< lower) $ takeWhile (<= upper) xs
 expandMDYPat lower upper (After x) = return [max lower x .. upper]
 expandMDYPat lower upper (Before x) = return [lower .. min upper x]
 expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
@@ -151,7 +156,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- asks (unBSpan . csBudgetScope)
+  globalSpan <- asks (unBSpan . tsBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -494,7 +499,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       , ("description", doubleQuote $ unTxDesc e)
       ]
 
-showMatch :: MatchRe -> T.Text
+showMatch :: StatementParserRe -> T.Text
 showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
@@ -599,7 +604,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
 lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
-lookupAccount = lookupFinance AcntField csAccountMap
+lookupAccount = lookupFinance AcntField tsAccountMap
 
 lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
 lookupAccountKey = fmap fst . lookupAccount
@@ -608,7 +613,7 @@ lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap snd . lookupAccount
 
 lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
-lookupCurrency = lookupFinance CurField csCurrencyMap
+lookupCurrency = lookupFinance CurField tsCurrencyMap
 
 lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
@@ -617,12 +622,12 @@ lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
-lookupTag = lookupFinance TagField csTagMap
+lookupTag = lookupFinance TagField tsTagMap
 
 lookupFinance
   :: (MonadAppError m, MonadFinance m, Ord k, Show k)
   => EntryIDType
-  -> (ConfigState -> M.Map k a)
+  -> (TxState -> M.Map k a)
   -> k
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
@@ -639,39 +644,38 @@ balanceTxs ebs =
       fmap (Just . Left) $
         liftInnerS $
           either rebalanceTotalEntrySet rebalanceFullEntrySet utx
-    go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
-      modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
+      modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
-      e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
+    go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
+      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
       es <- mapErrors (goOther tot) txOther
-      let tx =
-            -- TODO this is lame
-            InsertTx
-              { itxDescr = txDescr
-              , itxDate = txDate
-              , itxEntrySets = e :| es
-              , itxCommit = txCommit
-              , itxBudget = txBudget
-              , itxPriority = txPriority
-              }
+      let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
       return $ Just $ Right tx
       where
         goOther tot =
           either
-            (balanceSecondaryEntrySet txBudget)
-            (balancePrimaryEntrySet txBudget . fromShadow tot)
+            balanceSecondaryEntrySet
+            (balancePrimaryEntrySet . fromShadow tot)
         fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
-binDate :: EntryCRU -> (Day, Int)
-binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
-binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
+-- NOTE this sorting thing is super wonky; I'm basically sorting three different
+-- levels of the hierarchy directory and assuming there will be no overlaps.
+-- First, sort at the transaction level by day, priority, and description as
+-- tiebreaker. Anything that shares those three keys will have an unstable sort
+-- order. Within the entrysets, use the index as it appears in the
+-- configuration, and same with the entries. Since we assume no overlap, nothing
+-- "bad" should happen if the levels above entries/entrysets sort on 'Nothing'
+-- for the indices they don't have at their level.
+binDate :: EntryCRU -> (TxSortKey, Maybe EntrySetIndex, Maybe EntryIndex)
+binDate (ToRead ReadEntry {reSortKey, reESIndex, reIndex}) = (reSortKey, Just reESIndex, Just reIndex)
+binDate (ToInsert Tx {txMeta = (TxMeta t p d _)}) = (TxSortKey t p d, Nothing, Nothing)
 binDate (ToUpdate u) = either go go u
   where
-    go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
+    go UpdateEntrySet {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
 
-type BCKey = (CurrencyRId, BudgetName)
+type BCKey = CurrencyRId
 
 type ABCKey = (AccountRId, BCKey)
 
@@ -692,17 +696,14 @@ rebalanceTotalEntrySet
     , utToRO
     , utCurrency
     , utTotalValue
-    , utBudget
     } =
     do
-      (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
+      (fval, fs, tpairs) <- rebalanceDebit utCurrency utFromRO utFromUnk
       let f0val = utTotalValue - fval
-      modify $ mapAdd_ (f0Acnt, bc) f0val
+      modify $ mapAdd_ (f0Acnt, utCurrency) f0val
       let tsLinked = tpairs ++ (unlink f0val <$> f0links)
-      ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
+      ts <- rebalanceCredit utCurrency utTotalValue utTo0 utToUnk utToRO tsLinked
       return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
-    where
-      bc = (utCurrency, utBudget)
 
 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@@ -714,17 +715,15 @@ rebalanceFullEntrySet
     , utFromRO
     , utToRO
     , utCurrency
-    , utBudget
     } =
     do
-      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
-      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
+      (ftot, fs, tpairs) <- rebalanceDebit utCurrency rs ls
+      ts <- rebalanceCredit utCurrency ftot utTo0 utToUnk utToRO tpairs
       return (fs ++ ts)
     where
       (rs, ls) = case utFrom0 of
         Left x -> (x : utFromRO, utFromUnk)
         Right x -> (utFromRO, x : utFromUnk)
-      bc = (utCurrency, utBudget)
 
 rebalanceDebit
   :: BCKey
@@ -758,7 +757,7 @@ rebalanceCredit
   -> [UE_RO]
   -> [UEBalanced]
   -> State EntryBals [UEBalanced]
-rebalanceCredit k tot t0 us rs bs = do
+rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
   (tval, ts) <-
     fmap (second catMaybes) $
       sumM goTo $
@@ -766,7 +765,9 @@ rebalanceCredit k tot t0 us rs bs = do
           (UETLinked <$> bs)
             ++ (UETUnk <$> us)
             ++ (UETReadOnly <$> rs)
-  return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
+  let t0val = -(tot + tval)
+  modify $ mapAdd_ (t0Acnt, k) t0val
+  return (t0 {ueValue = StaticValue t0val} : ts)
   where
     idx = projectUET ueIndex ueIndex ueIndex
     goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
@@ -806,11 +807,9 @@ updateUnknown k e = do
 
 balancePrimaryEntrySet
   :: (MonadAppError m, MonadFinance m)
-  => BudgetName
-  -> PrimaryEntrySet
+  => PrimaryEntrySet
   -> StateT EntryBals m InsertEntrySet
 balancePrimaryEntrySet
-  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -822,7 +821,7 @@ balancePrimaryEntrySet
       let t0res = resolveAcntAndTags t0
       let fsres = mapErrors resolveAcntAndTags fs
       let tsres = mapErrors resolveAcntAndTags ts
-      let bc = (esCurrency, budgetName)
+      let bc = esCurrency
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
           let balFrom = fmap liftInnerS . balanceDeferred
@@ -831,11 +830,9 @@ balancePrimaryEntrySet
 
 balanceSecondaryEntrySet
   :: (MonadAppError m, MonadFinance m)
-  => BudgetName
-  -> SecondayEntrySet
+  => SecondayEntrySet
   -> StateT EntryBals m InsertEntrySet
 balanceSecondaryEntrySet
-  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -852,7 +849,7 @@ balanceSecondaryEntrySet
     where
       entrySum = sum . fmap (eValue . ieEntry)
       balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
-      bc = (esCurrency, budgetName)
+      bc = esCurrency
 
 balanceFinal
   :: (MonadAppError m)
@@ -862,10 +859,10 @@ balanceFinal
   -> Entry AccountRId () TagRId
   -> [Entry AccountRId EntryLink TagRId]
   -> StateT EntryBals m InsertEntrySet
-balanceFinal k@(curID, _) tot fs t0 ts = do
+balanceFinal curID tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
   let balTo = balanceLinked fv
-  ts' <- balanceTotalEntrySet balTo k tot t0 ts
+  ts' <- balanceTotalEntrySet balTo curID tot t0 ts
   return $
     InsertEntrySet
       { iesCurrency = curID
@@ -963,20 +960,18 @@ findBalance k e = do
 expandTransfers
   :: (MonadAppError m, MonadFinance m)
   => CommitR
-  -> BudgetName
   -> DaySpan
   -> [PairedTransfer]
   -> m [Tx CommitR]
-expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
+expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
 
 expandTransfer
   :: (MonadAppError m, MonadFinance m)
   => CommitR
-  -> BudgetName
   -> DaySpan
   -> PairedTransfer
   -> m [Tx CommitR]
-expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
   txs <- mapErrors go transAmounts
   return $ concat txs
   where
@@ -997,13 +992,9 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         withDates bounds pat $ \day ->
           return
             Tx
-              { txCommit = tc
-              , txDate = day
+              { txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
               , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
               , txOther = []
-              , txDescr = TxDesc desc
-              , txBudget = name
-              , txPriority = fromIntegral pri
               }
 
 entryPair
@@ -1050,3 +1041,26 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p)
 
 roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
 roundToP p = roundTo (unPrecision p)
+
+compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
+compileRegex groups pat = case res of
+  Right re -> return (pat, re)
+  Left _ -> throwError $ AppException [RegexError pat]
+  where
+    res =
+      compile
+        (blankCompOpt {newSyntax = True})
+        (blankExecOpt {captureGroups = groups})
+        pat
+
+matchMaybe :: T.Text -> Regex -> AppExcept Bool
+matchMaybe q re = case execute re q of
+  Right res -> return $ isJust res
+  Left _ -> throwError $ AppException [RegexError "this should not happen"]
+
+matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
+matchGroupsMaybe q re = case regexec re q of
+  Right Nothing -> []
+  Right (Just (_, _, _, xs)) -> xs
+  -- this should never fail as regexec always returns Right
+  Left _ -> []