Merge branch 'update_dhall_types'

app/Main.hs

@@ -2,8 +2,12 @@
 
 module Main (main) where
 
+import Control.Monad.Except
+import Control.Monad.IO.Rerunnable
+import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Text.IO as TI
+import Database.Persist.Monad
 import Internal.Config
 import Internal.Database.Ops
 import Internal.Insert
@@ -103,7 +107,7 @@ sync =
 parse :: Options -> IO ()
 parse (Options c Reset) = do
   config <- readConfig c
-  migrate_ (sqlConfig config) nukeTables
+  runDB (sqlConfig config) nukeTables
 parse (Options c DumpAccounts) = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies) = runDumpCurrencies c
@@ -155,19 +159,31 @@ runDumpAccountKeys c = do
     t3 (_, _, x) = x
     double x = (x, x)
 
-runSync :: MonadUnliftIO m => FilePath -> m ()
+runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  handle err $ migrate_ (sqlConfig config) $ do
-    res <- getDBState config
-    case res of
-      Left es -> throwIO $ InsertException es
-      Right s -> do
-        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
-        es1 <- concat <$> mapM (run . insertBudget) (budget config)
-        es2 <- run $ insertStatements config
-        let es = es1 ++ es2
-        unless (null es) $ throwIO $ InsertException es
+  let (hTs, hSs) = splitHistory $ statements config
+  pool <- runNoLoggingT $ mkPool $ sqlConfig config
+  handle err $ do
+    -- _ <- askLoggerIO
+
+    -- get the current DB state
+    s <- runSqlQueryT pool $ do
+      runMigration migrateAll
+      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+
+    -- read desired statements from disk
+    bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs
+
+    -- update the DB
+    runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
+      let hTransRes = mapErrors insertHistTransfer hTs
+      let bgtRes = mapErrors insertBudget $ budget config
+      updateDBState -- TODO this will only work if foreign keys are deferred
+      res <- runExceptT $ do
+        mapM_ (uncurry insertHistStmt) bSs
+        combineError hTransRes bgtRes $ \_ _ -> ()
+      rerunnableIO $ fromEither res
   where
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es

budget.cabal

@@ -29,6 +29,7 @@ library
       Internal.Database.Ops
       Internal.Insert
       Internal.Statement
+      Internal.TH
       Internal.Types
       Internal.Utils
   other-modules:
@@ -88,6 +89,7 @@ library
     , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
+    , persistent-mtl >=0.3.0.0
     , persistent-sqlite
     , recursion-schemes
     , regex-tdfa
@@ -157,6 +159,7 @@ executable pwncash
     , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
+    , persistent-mtl >=0.3.0.0
     , persistent-sqlite
     , recursion-schemes
     , regex-tdfa

dhall/Accounts.dhall

@@ -1,50 +0,0 @@
-let List/map =
-      https://prelude.dhall-lang.org/v21.1.0/List/map
-        sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680
-
-let AccountTree
-    : Type
-    = forall (a : Type) ->
-      forall  ( Fix
-              : < AccountF : { _1 : Text, _2 : Text }
-                | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
-                > ->
-                  a
-              ) ->
-        a
-
-let AccountTreeF =
-      \(a : Type) ->
-        < AccountF : { _1 : Text, _2 : Text }
-        | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
-        >
-
-let Account
-    : Text -> Text -> AccountTree
-    = \(desc : Text) ->
-      \(name : Text) ->
-      \(a : Type) ->
-        let f = AccountTreeF a
-
-        in  \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name })
-
-let Placeholder
-    : Text -> Text -> List AccountTree -> AccountTree
-    = \(desc : Text) ->
-      \(name : Text) ->
-      \(children : List AccountTree) ->
-      \(a : Type) ->
-        let f = AccountTreeF a
-
-        in  \(Fix : f -> a) ->
-              let apply = \(x : AccountTree) -> x a Fix
-
-              in  Fix
-                    ( f.PlaceholderF
-                        { _1 = desc
-                        , _2 = name
-                        , _3 = List/map AccountTree a apply children
-                        }
-                    )
-
-in  { Account, Placeholder }

dhall/common.dhall

@@ -4,29 +4,16 @@ let List/map =
 
 let T = ./Types.dhall
 
-let dec =
-      \(s : Bool) ->
-      \(w : Natural) ->
-      \(d : Natural) ->
-      \(p : Natural) ->
-        { whole = w, decimal = d, precision = p, sign = s } : T.Decimal
-
-let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2
-
-let d = dec2 True
-
-let d_ = dec2 False
-
 let nullSplit =
-      \(a : T.SplitAcnt) ->
-      \(c : T.SplitCur) ->
-        T.ExpSplit::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID }
+      \(a : T.EntryAcntGetter) ->
+      \(c : T.EntryCurGetter) ->
+        T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
 
 let nullOpts = T.TxOpts::{=}
 
-let nullVal = T.MatchVal::{=}
+let nullVal = T.ValMatcher::{=}
 
-let nullMatch = T.Match::{=}
+let nullMatch = T.StatementParser::{=}
 
 let nullCron = T.CronPat::{=}
 
@@ -41,20 +28,20 @@ let cron1 =
       \(d : Natural) ->
         T.DatePat.Cron
           (     nullCron
-            //  { cronYear = Some (T.MDYPat.Single y)
-                , cronMonth = Some (T.MDYPat.Single m)
-                , cronDay = Some (T.MDYPat.Single d)
+            //  { cpYear = Some (T.MDYPat.Single y)
+                , cpMonth = Some (T.MDYPat.Single m)
+                , cpDay = Some (T.MDYPat.Single d)
                 }
           )
 
 let matchInf_ = nullMatch
 
-let matchInf = \(x : T.ToTx) -> nullMatch // { mTx = Some x }
+let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
 
-let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n }
+let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
 
 let matchN =
-      \(n : Natural) -> \(x : T.ToTx) -> matchInf x // { mTimes = Some n }
+      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
 
 let match1_ = matchN_ 1
 
@@ -68,61 +55,63 @@ let greg =
       \(d : Natural) ->
         { gYear = y, gMonth = m, gDay = d }
 
-let mY = \(y : Natural) -> T.MatchDate.On (T.MatchYMD.Y y)
+let mY = \(y : Natural) -> T.DateMatcher.On (T.YMDMatcher.Y y)
 
 let mYM =
       \(y : Natural) ->
       \(m : Natural) ->
-        T.MatchDate.On (T.MatchYMD.YM (gregM y m))
+        T.DateMatcher.On (T.YMDMatcher.YM (gregM y m))
 
 let mYMD =
       \(y : Natural) ->
       \(m : Natural) ->
       \(d : Natural) ->
-        T.MatchDate.On (T.MatchYMD.YMD (greg y m d))
+        T.DateMatcher.On (T.YMDMatcher.YMD (greg y m d))
 
 let mRngY =
       \(y : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.Y y, _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.Y y, _2 = r }
 
 let mRngYM =
       \(y : Natural) ->
       \(m : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.YM (gregM y m), _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.YM (gregM y m), _2 = r }
 
 let mRngYMD =
       \(y : Natural) ->
       \(m : Natural) ->
       \(d : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.YMD (greg y m d), _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
 
-let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text }
+let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
 
 let partN =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
       \(ss : List PartSplit) ->
         let toSplit =
               \(x : PartSplit) ->
-                    nullSplit (T.SplitAcnt.ConstT x._1) c
-                //  { sValue = Some (T.SplitNum.ConstN x._2), sComment = x._3 }
+                    nullSplit (T.EntryAcntGetter.ConstT x._1) c
+                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
+                    , eComment = x._3
+                    }
 
-        in    [ nullSplit a c // { sComment = comment } ]
-            # List/map PartSplit T.ExpSplit.Type toSplit ss
+        in    [ nullSplit a c // { eComment = comment } ]
+            # List/map PartSplit T.EntryGetter.Type toSplit ss
 
 let part1 =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
         partN c a comment ([] : List PartSplit)
 
 let part1_ =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
         partN c a "" ([] : List PartSplit)
 
 let addDay =
@@ -130,21 +119,21 @@ let addDay =
       \(d : Natural) ->
         { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
 
-let mvP = nullVal // { mvSign = Some True }
+let mvP = nullVal // { vmSign = Some True }
 
-let mvN = nullVal // { mvSign = Some False }
+let mvN = nullVal // { vmSign = Some False }
 
-let mvNum = \(x : Natural) -> nullVal // { mvNum = Some x }
+let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
 
-let mvDen = \(x : Natural) -> nullVal // { mvDen = Some x }
+let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
 
-let mvNumP = \(x : Natural) -> mvP // { mvNum = Some x }
+let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
 
-let mvNumN = \(x : Natural) -> mvN // { mvNum = Some x }
+let mvNumN = \(x : Natural) -> mvN // { vmNum = Some x }
 
-let mvDenP = \(x : Natural) -> mvP // { mvDen = Some x }
+let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
 
-let mvDenN = \(x : Natural) -> mvN // { mvDen = Some x }
+let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
 
 in      { nullSplit
         , nullMatch
@@ -182,9 +171,5 @@ in      { nullSplit
         , mvDenP
         , mvDenN
         , PartSplit
-        , d
-        , d_
-        , dec
-        , dec2
         }
     /\  T

lib/Internal/Database/Ops.hs

@@ -1,21 +1,26 @@
 module Internal.Database.Ops
-  ( migrate_
+  ( runDB
   , nukeTables
   , updateHashes
+  , updateDBState
   , getDBState
   , tree2Records
   , flattenAcntRoot
   , paths2IDs
+  , mkPool
   )
 where
 
 import Conduit
+import Control.Monad.Except
 import Control.Monad.Logger
 import Data.Hashable
-import Database.Esqueleto.Experimental
-import Database.Persist.Sql hiding (delete, (==.), (||.))
-import Database.Persist.Sqlite hiding (delete, (==.), (||.))
-import Database.Sqlite hiding (Config)
+import Database.Esqueleto.Experimental ((==.), (^.))
+import qualified Database.Esqueleto.Experimental as E
+import Database.Esqueleto.Internal.Internal (SqlSelect)
+import Database.Persist.Monad
+-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
+import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
 import GHC.Err
 import Internal.Types
 import Internal.Utils
@@ -26,31 +31,27 @@ import qualified RIO.Map as M
 import qualified RIO.NonEmpty as N
 import qualified RIO.Text as T
 
-migrate_
+runDB
   :: MonadUnliftIO m
   => SqlConfig
-  -> SqlPersistT (ResourceT (NoLoggingT m)) ()
-  -> m ()
-migrate_ c more =
-  runNoLoggingT $
-    runResourceT $
-      withSqlConn
-        (openConnection c)
-        ( \backend ->
-            flip runSqlConn backend $ do
-              _ <- askLoggerIO
+  -> SqlQueryT (NoLoggingT m) a
+  -> m a
+runDB c more =
+  runNoLoggingT $ do
+    pool <- mkPool c
+    runSqlQueryT pool $ do
+      _ <- lift askLoggerIO
       runMigration migrateAll
       more
-        )
 
-openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
-openConnection c logfn = case c of
-  Sqlite p -> liftIO $ do
-    conn <- open p
-    wrapConnection conn logfn
+mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
+mkPool c = case c of
+  Sqlite p -> createSqlitePool p 10
+  -- conn <- open p
+  -- wrapConnection conn logfn
   Postgres -> error "postgres not implemented"
 
-nukeTables :: MonadUnliftIO m => SqlPersistT m ()
+nukeTables :: MonadSqlQuery m => m ()
 nukeTables = do
   deleteWhere ([] :: [Filter CommitR])
   deleteWhere ([] :: [Filter CurrencyR])
@@ -98,8 +99,8 @@ hashConfig
     } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
     where
       (ms, ps) = partitionEithers $ fmap go ss
-      go (StmtManual x) = Left x
-      go (StmtImport x) = Right x
+      go (HistTransfer x) = Left x
+      go (HistStatement x) = Right x
 
 setDiff :: Eq a => [a] -> [a] -> ([a], [a])
 -- setDiff = setDiff' (==)
@@ -118,99 +119,67 @@ setDiff as bs = (as \\ bs, bs \\ as)
 --       | f a b = Just bs
 --       | otherwise = inB a bs
 
-getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
+getDBHashes :: MonadSqlQuery m => m [Int]
 getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
 
-nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
-nukeDBHash h = delete $ do
-  c <- from table
-  where_ (c ^. CommitRHash ==. val h)
+nukeDBHash :: MonadSqlQuery m => Int -> m ()
+nukeDBHash h = deleteE $ do
+  c <- E.from E.table
+  E.where_ (c ^. CommitRHash ==. E.val h)
 
-nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
+nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
+getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
 getConfigHashes c = do
   let ch = hashConfig c
   dh <- getDBHashes
   return $ setDiff dh ch
 
-updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
-updateHashes c = do
-  (del, new) <- getConfigHashes c
-  nukeDBHashes del
-  return new
+dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
+dumpTbl = selectE $ E.from E.table
 
-dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
-dumpTbl = select $ from table
-
-deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
-deleteAccount e = delete $ do
-  c <- from $ table @AccountR
-  where_ (c ^. AccountRId ==. val k)
+deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
+deleteAccount e = deleteE $ do
+  c <- E.from $ E.table @AccountR
+  E.where_ (c ^. AccountRId ==. E.val k)
   where
     k = entityKey e
 
-deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
-deleteCurrency e = delete $ do
-  c <- from $ table @CurrencyR
-  where_ (c ^. CurrencyRId ==. val k)
+deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
+deleteCurrency e = deleteE $ do
+  c <- E.from $ E.table @CurrencyR
+  E.where_ (c ^. CurrencyRId ==. E.val k)
   where
     k = entityKey e
 
-deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
-deleteTag e = delete $ do
-  c <- from $ table @TagR
-  where_ (c ^. TagRId ==. val k)
+deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
+deleteTag e = deleteE $ do
+  c <- E.from $ E.table @TagR
+  E.where_ (c ^. TagRId ==. E.val k)
   where
     k = entityKey e
 
-updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
-updateAccounts ar = do
-  let (acnts, paths, acntMap) = indexAcntRoot ar
-  acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff acnts acnts'
-  deleteWhere ([] :: [Filter AccountPathR])
-  mapM_ deleteAccount toDel
-  -- liftIO $ mapM_ print toDel
-  mapM_ insertFull toIns
-  mapM_ insert paths
-  return acntMap
-
 -- TODO slip-n-slide code...
 insertFull
-  :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
+  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
   => Entity r
-  -> ReaderT b m ()
+  -> m ()
 insertFull (Entity k v) = insertKey k v
 
-updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
-updateCurrencies cs = do
-  let curs = fmap currency2Record cs
-  curs' <- select $ from $ table @CurrencyR
-  let (toIns, toDel) = setDiff curs curs'
-  mapM_ deleteCurrency toDel
-  mapM_ insertFull toIns
-  return $ currencyMap curs
-
 currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname
+currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
+  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
-currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
-
-updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
-updateTags cs = do
-  let tags = fmap toRecord cs
-  tags' <- select $ from $ table @TagR
-  let (toIns, toDel) = setDiff tags tags'
-  mapM_ deleteTag toDel
-  mapM_ insertFull toIns
-  return $ tagMap tags
-  where
-    toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+currencyMap =
+  M.fromList
+    . fmap
+      ( \e ->
+          ( currencyRSymbol $ entityVal e
+          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
+          )
+      )
 
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
@@ -317,26 +286,81 @@ indexAcntRoot r =
     (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
 
 getDBState
-  :: MonadUnliftIO m
+  :: (MonadInsertError m, MonadSqlQuery m)
   => Config
-  -> SqlPersistT m (EitherErrs (FilePath -> DBState))
+  -> m (FilePath -> DBState)
 getDBState c = do
-  am <- updateAccounts $ accounts c
-  cm <- updateCurrencies $ currencies c
-  ts <- updateTags $ tags c
-  hs <- updateHashes c
+  (del, new) <- getConfigHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
-  return $ concatEither2 bi si $ \b s f ->
+  combineError bi si $ \b s f ->
+    -- TODO this can be cleaned up, half of it is meant to be queried when
+    -- determining how to insert budgets/history and the rest is just
+    -- holdover data to delete upon successful insertion
     DBState
-      { kmCurrency = cm
+      { kmCurrency = currencyMap cs
       , kmAccount = am
       , kmBudgetInterval = b
       , kmStatementInterval = s
-      , kmNewCommits = hs
+      , kmNewCommits = new
+      , kmOldCommits = del
       , kmConfigDir = f
-      , kmTag = ts
+      , kmTag = tagMap ts
+      , kmTagAll = ts
+      , kmAcntPaths = paths
+      , kmAcntsOld = acnts
+      , kmCurrenciesOld = cs
       }
   where
-    bi = resolveBounds $ budgetInterval $ global c
-    si = resolveBounds $ statementInterval $ global c
+    bi = liftExcept $ resolveBounds $ budgetInterval $ global c
+    si = liftExcept $ resolveBounds $ statementInterval $ global c
+    (acnts, paths, am) = indexAcntRoot $ accounts c
+    cs = currency2Record <$> currencies c
+    ts = toRecord <$> tags c
+    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+
+updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateHashes = do
+  old <- askDBState kmOldCommits
+  nukeDBHashes old
+
+updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateTags = do
+  tags <- askDBState kmTagAll
+  tags' <- selectE $ E.from $ E.table @TagR
+  let (toIns, toDel) = setDiff tags tags'
+  mapM_ deleteTag toDel
+  mapM_ insertFull toIns
+
+updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateAccounts = do
+  acnts <- askDBState kmAcntsOld
+  paths <- askDBState kmAcntPaths
+  acnts' <- dumpTbl
+  let (toIns, toDel) = setDiff acnts acnts'
+  deleteWhere ([] :: [Filter AccountPathR])
+  mapM_ deleteAccount toDel
+  mapM_ insertFull toIns
+  mapM_ insert paths
+
+updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateCurrencies = do
+  curs <- askDBState kmCurrenciesOld
+  curs' <- selectE $ E.from $ E.table @CurrencyR
+  let (toIns, toDel) = setDiff curs curs'
+  mapM_ deleteCurrency toDel
+  mapM_ insertFull toIns
+
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState = do
+  updateHashes
+  updateTags
+  updateAccounts
+  updateCurrencies
+
+deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
+deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
+
+selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
+selectE q = unsafeLiftSql "esqueleto-select" (E.select q)

lib/Internal/Statement.hs

@@ -5,6 +5,8 @@ module Internal.Statement
   )
 where
 
+import Control.Monad.Error.Class
+import Control.Monad.Except
 import Data.Csv
 import Internal.Types
 import Internal.Utils
@@ -18,32 +20,33 @@ import RIO.Time
 import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
-
-readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
-readImport Import {..} = do
-  let ores = plural $ compileOptions impTxOpts
-  let cres = concatEithersL $ compileMatch <$> impMatches
-  case concatEithers2 ores cres (,) of
-    Right (compiledOptions, compiledMatches) -> do
-      ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
-      case concatEitherL ires of
-        Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
-        Left es -> return $ Left es
-    Left es -> return $ Left es
+readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
+readImport Statement {..} = 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 stmtPaths
+  m <- askDBState kmCurrency
+  fromEither $
+    flip runReader m $
+      runExceptT $
+        matchRecords compiledMatches records
 
 readImport_
-  :: MonadFinance m
+  :: (MonadUnliftIO m, MonadFinance m)
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
-  -> m (EitherErr [TxRecord])
+  -> m [TxRecord]
 readImport_ n delim tns p = do
   dir <- askDBState kmConfigDir
-  bs <- liftIO $ BL.readFile $ dir </> p
+  res <- tryIO $ BL.readFile $ dir </> p
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> return $ Left $ ParseError $ T.pack m
-    Right (_, v) -> return $ Right $ catMaybes $ V.toList v
+    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Right (_, v) -> return $ catMaybes $ V.toList v
   where
     opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
     skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@@ -62,27 +65,25 @@ parseTxRecord p TxOpts {..} r = do
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx]
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    (ms_, [], []) -> do
     -- TODO record number of times each match hits for debugging
-      matched_ <- first (: []) $ mapM balanceTx ms_
-      Right matched_
-    (_, us, ns) -> Left [StatementError us ns]
+    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
   fmap matchToGroup
-    . L.groupBy (\a b -> mPriority a == mPriority b)
-    . L.sortOn (Down . mPriority)
+    . L.groupBy (\a b -> spPriority a == spPriority b)
+    . L.sortOn (Down . spPriority)
 
 matchToGroup :: [MatchRe] -> MatchGroup
 matchToGroup ms =
   uncurry MatchGroup $
-    first (L.sortOn mDate) $
-      L.partition (isJust . mDate) ms
+    first (L.sortOn spDate) $
+      L.partition (isJust . spDate) ms
 
 -- TDOO could use a better struct to flatten the maybe date subtype
 data MatchGroup = MatchGroup
@@ -124,10 +125,13 @@ zipperSlice f x = go
         EQ -> goEq $ Unzipped bs (a : cs) as
         LT -> z
 
-zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
+zipperMatch
+  :: Unzipped MatchRe
+  -> TxRecord
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
-    go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
+    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
     go prev (m : ms) = do
       res <- matches m x
       case res of
@@ -135,25 +139,30 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
         skipOrPass ->
           let ps = reverse prev
               ms' = maybe ms (: ms) (matchDec m)
-           in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
+           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
-zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
+-- TODO all this unpacking left/error crap is annoying
+zipperMatch'
+  :: Zipped MatchRe
+  -> TxRecord
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
       res <- matches a x
       case res of
         MatchFail -> go (Zipped (a : bs) as)
-        skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
-    go z' = Right (z', MatchFail)
+        skipOrPass ->
+          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
+    go z' = return (z', MatchFail)
 
 matchDec :: MatchRe -> Maybe MatchRe
-matchDec m = case mTimes m of
+matchDec m = case spTimes m of
   Just 1 -> Nothing
-  Just n -> Just $ m {mTimes = Just $ n - 1}
+  Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -163,17 +172,17 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
-  return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
+  return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      Right
+      return
         ( catMaybes matched
         , reverse unmatched
         , recoverZipper z
@@ -184,17 +193,17 @@ matchDates ms = go ([], [], initZipper ms)
         Right unzipped -> do
           (z', res) <- zipperMatch unzipped r
           let (m, u) = case res of
-                MatchPass p -> (Just p : matched, unmatched)
+                (MatchPass p) -> (Just p : matched, unmatched)
                 MatchSkip -> (Nothing : matched, unmatched)
                 MatchFail -> (matched, r : unmatched)
           go (m, u, z') rs
-    findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
+    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      Right
+      return
         ( catMaybes matched
         , reverse unmatched
         , recoverZipper z
@@ -207,26 +216,26 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> EitherErr BalTx
+balanceTx :: RawTx -> InsertExcept BalTx
 balanceTx t@Tx {txSplits = ss} = do
   bs <- balanceSplits ss
   return $ t {txSplits = bs}
 
-balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
+balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
 balanceSplits ss =
   fmap concat
     <$> mapM (uncurry bal)
     $ groupByKey
-    $ fmap (\s -> (sCurrency s, s)) ss
+    $ fmap (\s -> (eCurrency s, s)) ss
   where
-    hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
-    hasValue s = Left s
+    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
+    haeValue s = Left s
     bal cur rss
-      | length rss < 2 = Left $ BalanceError TooFewSplits cur rss
-      | otherwise = case partitionEithers $ fmap hasValue rss of
-          ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
-          ([], val) -> Right val
-          _ -> Left $ BalanceError NotOneBlank cur rss
+      | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
+      | otherwise = case partitionEithers $ fmap haeValue rss of
+          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
+          ([], val) -> return val
+          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
 
 groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
 groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

lib/Internal/TH.hs

@@ -0,0 +1,12 @@
+module Internal.TH where
+
+import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
+import RIO
+
+deriveProduct :: [String] -> [String] -> Q [Dec]
+deriveProduct cs ss =
+  return $
+    [ StandaloneDerivD Nothing [] (AppT x y)
+    | x <- ConT . mkName <$> cs
+    , y <- ConT . mkName <$> ss
+    ]

lib/Internal/Types.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Internal.Types where
 
+import Control.Monad.Except
 import Data.Fix (Fix (..), foldFix)
 import Data.Functor.Foldable (embed)
 import qualified Data.Functor.Foldable.TH as TH
@@ -12,6 +14,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
 import Dhall hiding (embed, maybe)
 import Dhall.TH
+import Internal.TH (deriveProduct)
 import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
@@ -25,109 +28,131 @@ import Text.Regex.TDFA
 -------------------------------------------------------------------------------
 
 makeHaskellTypesWith
-  (defaultGenerateOptions {generateToDhallInstance = False})
+  (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
   [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
   , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
   , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
   , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
   , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
-  , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
-  , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
-  , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
-  , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
+  , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
+  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
+  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
+  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
+  , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
-  , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
+  , SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
   , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
   , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
   , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
-  , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
-  , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
-  , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
+  , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-    -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-    -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-    -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
-    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
-  , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
+  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
+  , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
+    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
+  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
+  , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
+  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
+  , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
+  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
+  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
+  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
+  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
+  , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
+  , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
+  -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
+  -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
+  -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
+  -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
+  -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
+  ]
+
+deriveProduct
+  ["Eq", "Show", "Generic", "FromDhall"]
+  [ "Currency"
+  , "Tag"
+  , "TimeUnit"
+  , "Weekday"
+  , "WeekdayPat"
+  , "RepeatPat"
+  , "MDYPat"
+  , "Gregorian"
+  , "GregorianM"
+  , "Interval"
+  , "ModPat"
+  , "CronPat"
+  , "DatePat"
+  , "TaggedAcnt"
+  , "Budget"
+  , "Income"
+  , "ShadowTransfer"
+  , "TransferMatcher"
+  , "AcntSet"
+  , "DateMatcher"
+  , "ValMatcher"
+  , "YMDMatcher"
+  , "BudgetCurrency"
+  , "Exchange"
+  , "EntryNumGetter"
+  , "TemporalScope"
+  , "SqlConfig"
+  , "PretaxValue"
+  , "TaxValue"
+  , "TaxBracket"
+  , "TaxProgression"
+  , "TaxMethod"
+  , "PosttaxValue"
+  , "BudgetTransferValue"
+  , "BudgetTransferType"
+  , "Period"
+  , "PeriodType"
+  , "HourlyPeriod"
   ]
 
 -------------------------------------------------------------------------------
 -- lots of instances for dhall types
 
-deriving instance Eq Currency
-
 deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
-deriving instance Eq Tag
-
 deriving instance Lift Tag
 
 deriving instance Hashable Tag
 
-deriving instance Eq TimeUnit
-
 deriving instance Ord TimeUnit
 
-deriving instance Show TimeUnit
-
 deriving instance Hashable TimeUnit
 
-deriving instance Eq Weekday
-
 deriving instance Ord Weekday
 
-deriving instance Show Weekday
-
 deriving instance Hashable Weekday
 
 deriving instance Enum Weekday
 
-deriving instance Eq WeekdayPat
-
 deriving instance Ord WeekdayPat
 
-deriving instance Show WeekdayPat
-
 deriving instance Hashable WeekdayPat
 
-deriving instance Show RepeatPat
-
-deriving instance Eq RepeatPat
-
 deriving instance Ord RepeatPat
 
 deriving instance Hashable RepeatPat
 
-deriving instance Show MDYPat
-
-deriving instance Eq MDYPat
-
 deriving instance Ord MDYPat
 
 deriving instance Hashable MDYPat
 
-deriving instance Eq Gregorian
-
-deriving instance Show Gregorian
-
 deriving instance Hashable Gregorian
 
-deriving instance Eq GregorianM
-
-deriving instance Show GregorianM
-
 deriving instance Hashable GregorianM
 
 -- Dhall.TH rearranges my fields :(
@@ -144,57 +169,56 @@ instance Ord GregorianM where
     GregorianM {gmYear = y, gmMonth = m}
     GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
 
-deriving instance Eq Interval
-
-deriving instance Ord Interval
-
 deriving instance Hashable Interval
 
-deriving instance Eq ModPat
-
 deriving instance Ord ModPat
 
-deriving instance Show ModPat
-
 deriving instance Hashable ModPat
 
-deriving instance Eq CronPat
-
 deriving instance Ord CronPat
 
-deriving instance Show CronPat
-
 deriving instance Hashable CronPat
 
-deriving instance Eq DatePat
-
 deriving instance Ord DatePat
 
-deriving instance Show DatePat
-
 deriving instance Hashable DatePat
 
+type BudgetTransfer =
+  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+
+deriving instance Hashable BudgetTransfer
+
+deriving instance Generic BudgetTransfer
+
+deriving instance FromDhall BudgetTransfer
+
 data Budget = Budget
-  { budgetLabel :: Text
-  , incomes :: [Income]
-  , pretax :: [IntervalAllocation]
-  , tax :: [IntervalAllocation]
-  , posttax :: [IntervalAllocation]
-  , transfers :: [Transfer]
-  , shadowTransfers :: [ShadowTransfer]
+  { bgtLabel :: Text
+  , bgtIncomes :: [Income]
+  , bgtPretax :: [MultiAllocation PretaxValue]
+  , bgtTax :: [MultiAllocation TaxValue]
+  , bgtPosttax :: [MultiAllocation PosttaxValue]
+  , bgtTransfers :: [BudgetTransfer]
+  , bgtShadowTransfers :: [ShadowTransfer]
   }
 
-deriving instance Eq Budget
+deriving instance Hashable PretaxValue
 
-deriving instance Generic Budget
+deriving instance Hashable TaxBracket
+
+deriving instance Hashable TaxProgression
+
+deriving instance Hashable TaxMethod
+
+deriving instance Hashable TaxValue
+
+deriving instance Hashable PosttaxValue
 
 deriving instance Hashable Budget
 
-deriving instance FromDhall Budget
+deriving instance Hashable BudgetTransferValue
 
-deriving instance Show TaggedAcnt
-
-deriving instance Eq TaggedAcnt
+deriving instance Hashable BudgetTransferType
 
 deriving instance Hashable TaggedAcnt
 
@@ -203,70 +227,61 @@ deriving instance Ord TaggedAcnt
 type CurID = T.Text
 
 data Income = Income
-  { incGross :: Decimal
+  { incGross :: Double
   , incCurrency :: CurID
   , incWhen :: DatePat
-  , incPretax :: [Allocation]
-  , incTaxes :: [Allocation]
-  , incPosttax :: [Allocation]
+  , incPretax :: [SingleAllocation PretaxValue]
+  , incTaxes :: [SingleAllocation TaxValue]
+  , incPosttax :: [SingleAllocation PosttaxValue]
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
+  , incPayPeriod :: !Period
   }
 
-deriving instance Eq Income
+deriving instance Hashable HourlyPeriod
 
-deriving instance Generic Income
+deriving instance Hashable PeriodType
+
+deriving instance Hashable Period
 
 deriving instance Hashable Income
 
-deriving instance FromDhall Income
+deriving instance (Ord w, Ord v) => Ord (Amount w v)
 
-deriving instance Show Amount
+deriving instance Generic (Amount w v)
 
-deriving instance Eq Amount
+deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
 
-deriving instance Ord Amount
+deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
 
-deriving instance Hashable Amount
+-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
 
-deriving instance Show Exchange
+deriving instance (Show w, Show v) => Show (Amount w v)
 
-deriving instance Eq Exchange
+deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
 deriving instance Hashable Exchange
 
-deriving instance Show BudgetCurrency
-
-deriving instance Eq BudgetCurrency
-
 deriving instance Hashable BudgetCurrency
 
-data Allocation_ a = Allocation_
+data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
-  , alloAmts :: [a]
-  , alloCur :: BudgetCurrency
+  , alloAmts :: [Amount w v]
+  , alloCur :: CurID
   }
-  deriving (Show)
+  deriving (Eq, Show, Generic, Hashable)
 
-type Allocation = Allocation_ Amount
+instance Bifunctor Amount where
+  bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
 
-deriving instance Eq Allocation
+instance Bifunctor Allocation where
+  bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
 
-deriving instance Generic Allocation
+deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
 
-deriving instance Hashable Allocation
+type MultiAllocation = Allocation Interval
 
-deriving instance FromDhall Allocation
-
-type IntervalAllocation = Allocation_ IntervalAmount
-
-deriving instance Eq IntervalAllocation
-
-deriving instance Generic IntervalAllocation
-
-deriving instance Hashable IntervalAllocation
-
-deriving instance FromDhall IntervalAllocation
+type SingleAllocation = Allocation ()
 
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
@@ -278,98 +293,35 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-deriving instance Show AmountType
+-- this is necessary since dhall will reverse the order when importing
+instance Ord Interval where
+  compare
+    Interval {intStart = s0, intEnd = e0}
+    Interval {intStart = s1, intEnd = e1} =
+      compare (s0, e0) (s1, e1)
 
-deriving instance Eq AmountType
-
-deriving instance Ord AmountType
-
-deriving instance Hashable AmountType
-
-data TimeAmount a = TimeAmount
-  { taWhen :: a
-  , taAmt :: Amount
-  , taAmtType :: AmountType
+data Transfer a c w v = Transfer
+  { transFrom :: a
+  , transTo :: a
+  , transAmounts :: [Amount w v]
+  , transCurrency :: c
   }
-  deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
-
-type DateAmount = TimeAmount DatePat
-
--- deriving instance Eq DateAmount
-
--- deriving instance Generic DateAmount
-
--- deriving instance Hashable DateAmount
-
--- deriving instance FromDhall DateAmount
-
-type IntervalAmount = TimeAmount Interval
-
--- deriving instance Eq IntervalAmount
-
--- deriving instance Ord IntervalAmount
-
--- deriving instance Generic IntervalAmount
-
--- deriving instance Hashable IntervalAmount
-
--- deriving instance FromDhall IntervalAmount
-
-data Transfer = Transfer
-  { transFrom :: TaggedAcnt
-  , transTo :: TaggedAcnt
-  , transAmounts :: [DateAmount]
-  , transCurrency :: BudgetCurrency
-  }
-
-deriving instance Eq Transfer
-
-deriving instance Generic Transfer
-
-deriving instance Hashable Transfer
-
-deriving instance FromDhall Transfer
-
-deriving instance Eq ShadowTransfer
+  deriving (Eq, Show)
 
 deriving instance Hashable ShadowTransfer
 
-deriving instance Eq AcntSet
-
 deriving instance Hashable AcntSet
 
-deriving instance Eq ShadowMatch
+deriving instance Hashable TransferMatcher
 
-deriving instance Hashable ShadowMatch
+deriving instance Hashable ValMatcher
 
-deriving instance Eq MatchVal
+deriving instance Hashable YMDMatcher
 
-deriving instance Hashable MatchVal
-
-deriving instance Show MatchVal
-
-deriving instance Eq MatchYMD
-
-deriving instance Hashable MatchYMD
-
-deriving instance Show MatchYMD
-
-deriving instance Eq MatchDate
-
-deriving instance Hashable MatchDate
-
-deriving instance Show MatchDate
-
-deriving instance Eq Decimal
-
-deriving instance Ord Decimal
-
-deriving instance Hashable Decimal
-
-deriving instance Show Decimal
+deriving instance Hashable DateMatcher
 
 -- TODO this just looks silly...but not sure how to simplify it
-instance Ord MatchYMD where
+instance Ord YMDMatcher where
   compare (Y y) (Y y') = compare y y'
   compare (YM g) (YM g') = compare g g'
   compare (YMD g) (YMD g') = compare g g'
@@ -384,21 +336,13 @@ gregM :: Gregorian -> GregorianM
 gregM Gregorian {gYear = y, gMonth = m} =
   GregorianM {gmYear = y, gmMonth = m}
 
-instance Ord MatchDate where
+instance Ord DateMatcher where
   compare (On d) (On d') = compare d d'
   compare (In d r) (In d' r') = compare d d' <> compare r r'
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Eq SplitNum
-
-deriving instance Hashable SplitNum
-
-deriving instance Show SplitNum
-
-deriving instance Eq Manual
-
-deriving instance Hashable Manual
+deriving instance Hashable EntryNumGetter
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -431,10 +375,10 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 data Config_ a = Config_
-  { global :: !Global
+  { global :: !TemporalScope
   , budget :: ![Budget]
   , currencies :: ![Currency]
-  , statements :: ![Statement]
+  , statements :: ![History]
   , accounts :: !a
   , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
@@ -468,23 +412,30 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-data Statement
-  = StmtManual !Manual
-  | StmtImport !Import
-  deriving (Eq, Hashable, Generic, FromDhall)
+type HistTransfer = Transfer AcntID CurID DatePat Double
 
-data Split a v c t = Split
-  { sAcnt :: !a
-  , sValue :: !v
-  , sCurrency :: !c
-  , sComment :: !T.Text
-  , sTags :: ![t]
-  }
-  deriving (Eq, Generic, Hashable, Show)
+deriving instance Generic HistTransfer
 
-type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
+deriving instance Hashable HistTransfer
 
-instance FromDhall ExpSplit
+deriving instance FromDhall HistTransfer
+
+data History
+  = HistTransfer !HistTransfer
+  | HistStatement !Statement
+  deriving (Eq, Generic, Hashable, FromDhall)
+
+type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
+
+instance FromDhall EntryGetter
+
+deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
+
+deriving instance Generic (Entry a v c t)
+
+deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
+
+deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
 
 data Tx s = Tx
   { txDescr :: !T.Text
@@ -493,7 +444,7 @@ data Tx s = Tx
   }
   deriving (Generic)
 
-type ExpTx = Tx ExpSplit
+type ExpTx = Tx EntryGetter
 
 instance FromDhall ExpTx
 
@@ -507,66 +458,74 @@ data TxOpts re = TxOpts
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Import = Import
-  { impPaths :: ![FilePath]
-  , impMatches :: ![Match T.Text]
-  , impDelim :: !Word
-  , impTxOpts :: !(TxOpts T.Text)
-  , impSkipLines :: !Natural
+data Statement = Statement
+  { stmtPaths :: ![FilePath]
+  , stmtParsers :: ![StatementParser T.Text]
+  , stmtDelim :: !Word
+  , stmtTxOpts :: !(TxOpts T.Text)
+  , stmtSkipLines :: !Natural
   }
   deriving (Eq, Hashable, Generic, FromDhall)
 
 -- | the value of a field in split (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value
-data SplitText t
+data EntryTextGetter t
   = ConstT !t
   | LookupT !T.Text
   | MapT !(FieldMap T.Text t)
   | Map2T !(FieldMap (T.Text, T.Text) t)
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-type SplitCur = SplitText CurID
+type SplitCur = EntryTextGetter CurID
 
-type SplitAcnt = SplitText AcntID
+type SplitAcnt = EntryTextGetter AcntID
 
-data Field k v = Field
-  { fKey :: !k
-  , fVal :: !v
-  }
-  deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
+deriving instance (Show k, Show v) => Show (Field k v)
+
+deriving instance (Eq k, Eq v) => Eq (Field k v)
+
+deriving instance Generic (Field k v)
+
+deriving instance (Hashable k, Hashable v) => Hashable (Field k v)
+
+deriving instance Foldable (Field k)
+
+deriving instance Traversable (Field k)
+
+deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)
 
 instance Functor (Field f) where
   fmap f (Field k v) = Field k $ f v
 
 type FieldMap k v = Field k (M.Map k v)
 
-data MatchOther re
+data FieldMatcher re
   = Desc !(Field T.Text re)
-  | Val !(Field T.Text MatchVal)
+  | Val !(Field T.Text ValMatcher)
   deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
 
-deriving instance Show (MatchOther T.Text)
+deriving instance Show (FieldMatcher T.Text)
 
-data ToTx = ToTx
-  { ttCurrency :: !SplitCur
-  , ttPath :: !SplitAcnt
-  , ttSplit :: ![ExpSplit]
+data TxGetter = TxGetter
+  { tgCurrency :: !SplitCur
+  , tgAcnt :: !SplitAcnt
+  , tgEntries :: ![EntryGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Match re = Match
-  { mDate :: !(Maybe MatchDate)
-  , mVal :: !MatchVal
-  , mDesc :: !(Maybe re)
-  , mOther :: ![MatchOther re]
-  , mTx :: !(Maybe ToTx)
-  , mTimes :: !(Maybe Natural)
-  , mPriority :: !Integer
+data StatementParser re = StatementParser
+  { spDate :: !(Maybe DateMatcher)
+  , spVal :: !ValMatcher
+  , spDesc :: !(Maybe re)
+  , spOther :: ![FieldMatcher re]
+  , spTx :: !(Maybe TxGetter)
+  , spTimes :: !(Maybe Natural)
+  , spPriority :: !Integer
   }
   deriving (Eq, Generic, Hashable, FromDhall, Functor)
 
-deriving instance Show (Match T.Text)
+deriving instance Show (StatementParser T.Text)
 
 --------------------------------------------------------------------------------
 -- DATABASE MODEL
@@ -582,6 +541,7 @@ CommitR sql=commits
 CurrencyR sql=currencies
     symbol T.Text
     fullname T.Text
+    precision Int
     deriving Show Eq
 TagR sql=tags
     symbol T.Text
@@ -644,7 +604,7 @@ instance PersistField ConfigType where
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
-type CurrencyMap = M.Map CurID CurrencyRId
+type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
 
 type TagMap = M.Map TagID TagRId
 
@@ -655,12 +615,17 @@ data DBState = DBState
   , kmBudgetInterval :: !Bounds
   , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
+  , kmOldCommits :: ![Int]
   , kmConfigDir :: !FilePath
+  , kmTagAll :: ![Entity TagR]
+  , kmAcntPaths :: ![AccountPathR]
+  , kmAcntsOld :: ![Entity AccountR]
+  , kmCurrenciesOld :: ![Entity CurrencyR]
   }
 
-type MappingT m = ReaderT DBState (SqlPersistT m)
+type CurrencyM = Reader CurrencyMap
 
-type KeySplit = Split AccountRId Rational CurrencyRId TagRId
+type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
 
@@ -668,13 +633,12 @@ type TreeR = Tree ([T.Text], AccountRId)
 
 type Balances = M.Map AccountRId Rational
 
-type BalanceM m = ReaderT (MVar Balances) m
+type BalanceM = ReaderT (MVar Balances)
 
-class MonadUnliftIO m => MonadFinance m where
-  askDBState :: (DBState -> a) -> m a
+type MonadFinance = MonadReader DBState
 
-instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
-  askDBState = asks
+askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState = asks
 
 class MonadUnliftIO m => MonadBalance m where
   askBalances :: m (MVar Balances)
@@ -753,9 +717,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Split AcntID (Maybe Rational) CurID TagID
+type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
 
-type BalSplit = Split AcntID Rational CurID TagID
+type BalSplit = Entry AcntID Rational CurID TagID
 
 type RawTx = Tx RawSplit
 
@@ -797,19 +761,23 @@ data InsertError
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
   | BalanceError !BalanceType !CurID ![RawSplit]
-  | IncomeError !DatePat
+  | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
+  | PeriodError !Day !Day
   deriving (Show)
 
-newtype InsertException = InsertException [InsertError] deriving (Show)
+newtype InsertException = InsertException [InsertError]
+  deriving (Show, Semigroup) via [InsertError]
 
 instance Exception InsertException
 
-type EitherErr = Either InsertError
+type MonadInsertError = MonadError InsertException
 
-type EitherErrs = Either [InsertError]
+type InsertExceptT = ExceptT InsertException
+
+type InsertExcept = InsertExceptT Identity
 
 data XGregorian = XGregorian
   { xgYear :: !Int
@@ -818,11 +786,11 @@ data XGregorian = XGregorian
   , xgDayOfWeek :: !Int
   }
 
-type MatchRe = Match (T.Text, Regex)
+type MatchRe = StatementParser (T.Text, Regex)
 
 type TxOptsRe = TxOpts (T.Text, Regex)
 
-type MatchOtherRe = MatchOther (T.Text, Regex)
+type FieldMatcherRe = FieldMatcher (T.Text, Regex)
 
-instance Show (Match (T.Text, Regex)) where
+instance Show (StatementParser (T.Text, Regex)) where
   show = show . fmap fst

lib/Internal/Utils.hs

@@ -1,5 +1,6 @@
 module Internal.Utils
   ( compareDate
+  , fromWeekday
   , inBounds
   , expandBounds
   , fmtRational
@@ -7,16 +8,33 @@ module Internal.Utils
   , fromGregorian'
   , resolveBounds
   , resolveBounds_
-  , leftToMaybe
-  , dec2Rat
-  , concatEithers2
-  , concatEithers3
-  , concatEither3
-  , concatEither2
-  , concatEitherL
-  , concatEithersL
-  , concatEither2M
-  , concatEithers2M
+  , liftInner
+  , liftExceptT
+  , liftExcept
+  , liftIOExcept
+  , liftIOExceptT
+  , combineError
+  , combineError_
+  , combineError3
+  , combineErrors
+  , mapErrors
+  , combineErrorM
+  , combineErrorM3
+  , combineErrorIO2
+  , combineErrorIO3
+  , combineErrorIOM2
+  , combineErrorIOM3
+  , collectErrorsIO
+  , mapErrorsIO
+  -- , leftToMaybe
+  -- , concatEithers2
+  -- , concatEithers3
+  -- , concatEither3
+  -- , concatEither2
+  -- , concatEitherL
+  -- , concatEithersL
+  -- , concatEither2M
+  -- , concatEithers2M
   , parseRational
   , showError
   , unlessLeft_
@@ -32,14 +50,19 @@ module Internal.Utils
   , sndOf3
   , thdOf3
   , xGregToDay
-  , plural
+  -- , plural
   , compileMatch
   , compileOptions
   , dateMatches
   , valMatches
+  , roundPrecision
+  , roundPrecisionCur
   )
 where
 
+import Control.Monad.Error.Class
+import Control.Monad.Except
+import Control.Monad.Reader
 import Data.Time.Format.ISO8601
 import GHC.Real
 import Internal.Types
@@ -55,6 +78,16 @@ import Text.Regex.TDFA.Text
 --------------------------------------------------------------------------------
 -- dates
 
+-- | Lame weekday converter since day of weeks aren't in dhall (yet)
+fromWeekday :: Weekday -> DayOfWeek
+fromWeekday Mon = Monday
+fromWeekday Tue = Tuesday
+fromWeekday Wed = Wednesday
+fromWeekday Thu = Thursday
+fromWeekday Fri = Friday
+fromWeekday Sat = Saturday
+fromWeekday Sun = Sunday
+
 -- | find the next date
 -- this is meant to go in a very tight loop and be very fast (hence no
 -- complex date functions, most of which heavily use 'mod' and friends)
@@ -97,22 +130,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
 
 data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
 
-fromMatchYMD :: MatchYMD -> YMD_
-fromMatchYMD m = case m of
+fromYMDMatcher :: YMDMatcher -> YMD_
+fromYMDMatcher m = case m of
   Y y -> Y_ $ fromIntegral y
   YM g -> uncurry YM_ $ gregMTup g
   YMD g -> uncurry3 YMD_ $ gregTup g
 
-compareDate :: MatchDate -> Day -> Ordering
+compareDate :: DateMatcher -> Day -> Ordering
 compareDate (On md) x =
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compare y y'
     YM_ y' m' -> compare (y, m) (y', m')
     YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
   where
     (y, m, d) = toGregorian x
 compareDate (In md offset) x = do
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compareRange y' y
     YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
     YMD_ y' m' d' ->
@@ -132,17 +165,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup
 inBounds :: (Day, Day) -> Day -> Bool
 inBounds (d0, d1) x = d0 <= x && x < d1
 
-resolveBounds :: Interval -> EitherErr Bounds
+resolveBounds :: Interval -> InsertExcept Bounds
 resolveBounds i@Interval {intStart = s} =
   resolveBounds_ (s {gYear = gYear s + 50}) i
 
-resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
+resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
 resolveBounds_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of
-    Nothing -> Right $ toBounds $ fromGregorian' def
+    Nothing -> return $ toBounds $ fromGregorian' def
     Just e_
-      | s_ < e_ -> Right $ toBounds e_
-      | otherwise -> Left $ BoundsError s e
+      | s_ < e_ -> return $ toBounds e_
+      | otherwise -> throwError $ InsertException [BoundsError s e]
   where
     s_ = fromGregorian' s
     toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
@@ -153,103 +186,193 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
+matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
 matches
-  Match {mTx, mOther, mVal, mDate, mDesc}
+  StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    res <- concatEither3 val other desc $ \x y z -> x && y && z
-    if date && res
-      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
-      else Right MatchFail
+    res <- liftInner $
+      combineError3 val other desc $
+        \x y z -> x && y && z && date
+    if res
+      then maybe (return MatchSkip) convert spTx
+      else return MatchFail
     where
-      val = valMatches mVal trAmount
-      date = maybe True (`dateMatches` trDate) mDate
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
-      desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
-      convert (ToTx cur a ss) = toTx cur a ss r
+      val = valMatches spVal trAmount
+      date = maybe True (`dateMatches` trDate) spDate
+      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
+      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
+      convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
 
-toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
-toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
-  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
+toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
+toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
+  combineError3 acntRes curRes ssRes $ \a c ss ->
     let fromSplit =
-          Split
-            { sAcnt = a_
-            , sCurrency = c_
-            , sValue = Just trAmount
-            , sComment = ""
-            , sTags = [] -- TODO what goes here?
+          Entry
+            { eAcnt = a
+            , eCurrency = c
+            , eValue = Just trAmount
+            , eComment = ""
+            , eTags = [] -- TODO what goes here?
             }
      in Tx
           { txDate = trDate
           , txDescr = trDesc
-          , txSplits = fromSplit : ss_
+          , txSplits = fromSplit : ss
           }
   where
-    acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
-    ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
+    acntRes = liftInner $ resolveAcnt r sa
+    curRes = liftInner $ resolveCurrency r sc
+    ssRes = combineErrors $ fmap (resolveEntry r) toSplits
 
-valMatches :: MatchVal -> Rational -> EitherErr Bool
-valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
-  | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
+valMatches :: ValMatcher -> Rational -> InsertExcept Bool
+valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
+  | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
   | otherwise =
-      Right $
-        checkMaybe (s ==) mvSign
-          && checkMaybe (n ==) mvNum
-          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
+      return $
+        checkMaybe (s ==) vmSign
+          && checkMaybe (n ==) vmNum
+          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
   where
     (n, d) = properFraction $ abs x
-    p = 10 ^ mvPrec
+    p = 10 ^ vmPrec
     s = signum x >= 0
     checkMaybe = maybe True
 
-dateMatches :: MatchDate -> Day -> Bool
+dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
-otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
+otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
 otherMatches dict m = case m of
   Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
   Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
-resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
-  concatEithers2 acRes valRes $
-    \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
+resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
+resolveEntry 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 = v', eCurrency = c}
   where
-    acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
-    valRes = plural $ mapM (resolveValue r) v
+    acntRes = resolveAcnt r eAcnt
+    curRes = resolveCurrency r eCurrency
+    valRes = mapM (resolveValue r) eValue
 
-resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
+liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
+liftInner = mapExceptT (return . runIdentity)
+
+liftExceptT :: MonadError e m => ExceptT e m a -> m a
+liftExceptT x = runExceptT x >>= either throwError return
+
+liftExcept :: MonadError e m => Except e a -> m a
+liftExcept = either throwError return . runExcept
+
+-- tryError :: MonadError e m => m a -> m (Either e a)
+-- tryError action = (Right <$> action) `catchError` (pure . Left)
+
+liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
+liftIOExceptT = fromEither <=< runExceptT
+
+liftIOExcept :: MonadIO m => InsertExcept a -> m a
+liftIOExcept = fromEither . runExcept
+
+combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
+combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
+
+combineError_ :: MonadError InsertException m => m a -> m b -> m ()
+combineError_ a b = do
+  _ <- catchError a $ \e ->
+    throwError =<< catchError (e <$ b) (return . (e <>))
+  _ <- b
+  return ()
+
+combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
+combineErrorM a b f = do
+  a' <- catchError a $ \e ->
+    throwError =<< catchError (e <$ b) (return . (e <>))
+  f a' =<< b
+
+combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
+combineError3 a b c f =
+  combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
+
+combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
+combineErrorM3 a b c f = do
+  combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
+
+combineErrors :: MonadError InsertException m => [m a] -> m [a]
+combineErrors = mapErrors id
+
+mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
+mapErrors f xs = do
+  ys <- mapM (go . f) xs
+  case partitionEithers ys of
+    ([], zs) -> return zs
+    (e : es, _) -> throwError $ foldr (<>) e es
+  where
+    go x = catchError (Right <$> x) (pure . Left)
+
+combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
+combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
+
+combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
+combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
+
+combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
+combineErrorIOM2 a b f = do
+  a' <- catch a $ \(InsertException es) ->
+    (throwIO . InsertException)
+      =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
+  f a' =<< b
+
+combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
+combineErrorIOM3 a b c f =
+  combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
+
+mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
+mapErrorsIO f xs = do
+  ys <- mapM (go . f) xs
+  case partitionEithers ys of
+    ([], zs) -> return zs
+    (es, _) -> throwIO $ InsertException $ concat es
+  where
+    go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
+
+collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
+collectErrorsIO = mapErrorsIO id
+
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
 resolveValue r s = case s of
-  (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
-  (ConstN c) -> Right $ dec2Rat c
-  AmountN -> Right $ trAmount r
+  (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
+  (ConstN c) -> return c
+  -- TODO don't coerce to rational in trAmount
+  AmountN -> return $ fromRational $ trAmount r
 
-resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
 resolveAcnt = resolveSplitField AcntField
 
-resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
+resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
 resolveCurrency = resolveSplitField CurField
 
-resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
 resolveSplitField t TxRecord {trOther = o} s = case s of
-  ConstT p -> Right p
-  LookupT f -> plural $ lookup_ f o
-  MapT (Field f m) -> plural $ do
+  ConstT p -> return p
+  LookupT f -> lookup_ f o
+  MapT (Field f m) -> do
     k <- lookup_ f o
     lookup_ k m
   Map2T (Field (f1, f2) m) -> do
-    (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
-    plural $ lookup_ (k1, k2) m
+    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
+    lookup_ (k1, k2) m
   where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
     lookup_ = lookupErr (SplitIDField t)
 
-lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
+lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
 lookupErr what k m = case M.lookup k m of
-  Just x -> Right x
-  _ -> Left $ LookupError what $ showT k
+  Just x -> return x
+  _ -> throwError $ InsertException [LookupError what $ showT k]
 
 parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
 parseRational (pat, re) s = case matchGroupsMaybe s re of
@@ -278,7 +401,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
       k <- readSign sign
       return (k, w)
 
-readRational :: T.Text -> EitherErr Rational
+readDouble :: T.Text -> InsertExcept Double
+readDouble s = case readMaybe $ T.unpack s of
+  Just x -> return x
+  Nothing -> throwError $ InsertException [ConversionError s]
+
+readRational :: T.Text -> InsertExcept Rational
 readRational s = case T.split (== '.') s of
   [x] -> maybe err (return . fromInteger) $ readT x
   [x, y] -> case (readT x, readT y) of
@@ -290,7 +418,7 @@ readRational s = case T.split (== '.') s of
   _ -> err
   where
     readT = readMaybe . T.unpack
-    err = Left $ ConversionError s
+    err = throwError $ InsertException [ConversionError s]
 
 -- TODO smells like a lens
 -- mapTxSplits :: (a -> b) -> Tx a -> Tx b
@@ -307,11 +435,16 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
-dec2Rat :: Decimal -> Rational
-dec2Rat D {sign, whole, decimal, precision} =
-  k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
+roundPrecision :: Natural -> Double -> Rational
+roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
   where
-    k = if sign then 1 else -1
+    p = 10 ^ n
+
+roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
+roundPrecisionCur c m x =
+  case M.lookup c m of
+    Just (_, n) -> return $ roundPrecision n x
+    Nothing -> throwError $ InsertException [undefined]
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -371,8 +504,24 @@ showError other = case other of
       idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
-  (IncomeError dp) ->
-    [T.append "Income allocations exceed total: datepattern=" $ showT dp]
+  (IncomeError day name balance) ->
+    [ T.unwords
+        [ "Income allocations for budget"
+        , singleQuote name
+        , "exceed total on day"
+        , showT day
+        , "where balance is"
+        , showT (fromRational balance :: Double)
+        ]
+    ]
+  (PeriodError start next) ->
+    [ T.unwords
+        [ "First pay period on "
+        , singleQuote $ showT start
+        , "must start before first income payment on "
+        , singleQuote $ showT next
+        ]
+    ]
   (BalanceError t cur rss) ->
     [ T.unwords
         [ msg
@@ -402,32 +551,32 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       ]
 
 showMatch :: MatchRe -> T.Text
-showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
+showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
     kvs =
-      [ ("date", showMatchDate <$> d)
-      , ("val", showMatchVal v)
-      , ("desc", fst <$> e)
+      [ ("date", showDateMatcher <$> spDate)
+      , ("val", showValMatcher spVal)
+      , ("desc", fst <$> spDesc)
       , ("other", others)
-      , ("counter", Just $ maybe "Inf" showT n)
-      , ("priority", Just $ showT p)
+      , ("counter", Just $ maybe "Inf" showT spTimes)
+      , ("priority", Just $ showT spPriority)
       ]
-    others = case o of
+    others = case spOther of
       [] -> Nothing
       xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
 
 -- | Convert match date to text
 -- Single date matches will just show the single date, and ranged matches will
 -- show an interval like [YY-MM-DD, YY-MM-DD)
-showMatchDate :: MatchDate -> T.Text
-showMatchDate md = case md of
-  (On x) -> showMatchYMD x
-  (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
+showDateMatcher :: DateMatcher -> T.Text
+showDateMatcher md = case md of
+  (On x) -> showYMDMatcher x
+  (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
     where
       -- TODO not DRY (this shifting thing happens during the comparison
       -- function (kinda)
-      end = case fromMatchYMD start of
+      end = case fromYMDMatcher start of
         Y_ y -> Y_ $ y + fromIntegral n
         YM_ y m ->
           let (y_, m_) = divMod (m + fromIntegral n - 1) 12
@@ -439,8 +588,8 @@ showMatchDate md = case md of
                 fromGregorian y m d
 
 -- | convert YMD match to text
-showMatchYMD :: MatchYMD -> T.Text
-showMatchYMD = showYMD_ . fromMatchYMD
+showYMDMatcher :: YMDMatcher -> T.Text
+showYMDMatcher = showYMD_ . fromYMDMatcher
 
 showYMD_ :: YMD_ -> T.Text
 showYMD_ md =
@@ -451,19 +600,19 @@ showYMD_ md =
       YM_ y m -> [fromIntegral y, m]
       YMD_ y m d -> [fromIntegral y, m, d]
 
-showMatchVal :: MatchVal -> Maybe T.Text
-showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
+showValMatcher :: ValMatcher -> Maybe T.Text
+showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
+showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
   Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
-      [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
-      , ("numerator", showT <$> mvNum)
-      , ("denominator", showT <$> mvDen)
-      , ("precision", Just $ showT mvPrec)
+      [ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
+      , ("numerator", showT <$> vmNum)
+      , ("denominator", showT <$> vmDen)
+      , ("precision", Just $ showT vmPrec)
       ]
 
-showMatchOther :: MatchOtherRe -> T.Text
+showMatchOther :: FieldMatcherRe -> T.Text
 showMatchOther (Desc (Field f (re, _))) =
   T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
 showMatchOther (Val (Field f mv)) =
@@ -471,15 +620,15 @@ showMatchOther (Val (Field f mv)) =
     [ "val field"
     , singleQuote f
     , "with match value"
-    , singleQuote $ fromMaybe "*" $ showMatchVal mv
+    , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
 showSplit :: RawSplit -> T.Text
-showSplit Split {sAcnt = a, sValue = v, sComment = c} =
+showSplit Entry {eAcnt, eValue, eComment} =
   keyVals
-    [ ("account", a)
-    , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
-    , ("comment", doubleQuote c)
+    [ ("account", eAcnt)
+    , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
+    , ("comment", doubleQuote eComment)
     ]
 
 singleQuote :: T.Text -> T.Text
@@ -500,51 +649,51 @@ showT = T.pack . show
 --------------------------------------------------------------------------------
 -- pure error processing
 
-concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
-concatEither2 a b fun = case (a, b) of
-  (Right a_, Right b_) -> Right $ fun a_ b_
-  _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
+-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
+-- concatEither2 a b fun = case (a, b) of
+--   (Right a_, Right b_) -> Right $ fun a_ b_
+--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
 
-concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
-concatEither2M a b fun = case (a, b) of
-  (Right a_, Right b_) -> Right <$> fun a_ b_
-  _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
+-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
+-- concatEither2M a b fun = case (a, b) of
+--   (Right a_, Right b_) -> Right <$> fun a_ b_
+--   _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
 
-concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-concatEither3 a b c fun = case (a, b, c) of
-  (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
-  _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
+-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
+-- concatEither3 a b c fun = case (a, b, c) of
+--   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
+--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
 
-concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-concatEithers2 a b = merge . concatEither2 a b
+-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
+-- concatEithers2 a b = merge . concatEither2 a b
 
-concatEithers2M
-  :: Monad m
-  => Either [x] a
-  -> Either [x] b
-  -> (a -> b -> m c)
-  -> m (Either [x] c)
-concatEithers2M a b = fmap merge . concatEither2M a b
+-- concatEithers2M
+--   :: Monad m
+--   => Either [x] a
+--   -> Either [x] b
+--   -> (a -> b -> m c)
+--   -> m (Either [x] c)
+-- concatEithers2M a b = fmap merge . concatEither2M a b
 
-concatEithers3
-  :: Either [x] a
-  -> Either [x] b
-  -> Either [x] c
-  -> (a -> b -> c -> d)
-  -> Either [x] d
-concatEithers3 a b c = merge . concatEither3 a b c
+-- concatEithers3
+--   :: Either [x] a
+--   -> Either [x] b
+--   -> Either [x] c
+--   -> (a -> b -> c -> d)
+--   -> Either [x] d
+-- concatEithers3 a b c = merge . concatEither3 a b c
 
-concatEitherL :: [Either x a] -> Either [x] [a]
-concatEitherL as = case partitionEithers as of
-  ([], bs) -> Right bs
-  (es, _) -> Left es
+-- concatEitherL :: [Either x a] -> Either [x] [a]
+-- concatEitherL as = case partitionEithers as of
+--   ([], bs) -> Right bs
+--   (es, _) -> Left es
 
-concatEithersL :: [Either [x] a] -> Either [x] [a]
-concatEithersL = merge . concatEitherL
+-- concatEithersL :: [Either [x] a] -> Either [x] [a]
+-- concatEithersL = merge . concatEitherL
 
-leftToMaybe :: Either a b -> Maybe a
-leftToMaybe (Left a) = Just a
-leftToMaybe _ = Nothing
+-- leftToMaybe :: Either a b -> Maybe a
+-- leftToMaybe (Left a) = Just a
+-- leftToMaybe _ = Nothing
 
 unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
 unlessLeft (Left es) _ = return (return es)
@@ -560,11 +709,11 @@ unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
 unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
 unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 
-plural :: Either a b -> Either [a] b
-plural = first (: [])
+-- plural :: Either a b -> Either [a] b
+-- plural = first (: [])
 
-merge :: Either [[a]] b -> Either [a] b
-merge = first concat
+-- merge :: Either [[a]] b -> Either [a] b
+-- merge = first concat
 
 --------------------------------------------------------------------------------
 -- random functions
@@ -608,23 +757,23 @@ thdOf3 (_, _, c) = c
 --     -- these options barely do anything in terms of performance
 --     compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat
 
-compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe
+compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
 compileOptions o@TxOpts {toAmountFmt = pat} = do
   re <- compileRegex True pat
   return $ o {toAmountFmt = re}
 
-compileMatch :: Match T.Text -> EitherErrs MatchRe
-compileMatch m@Match {mDesc = d, mOther = os} = do
-  let dres = plural $ mapM go d
-  let ores = concatEitherL $ fmap (mapM go) os
-  concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
+compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
+compileMatch m@StatementParser {spDesc, spOther} = do
+  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
   where
     go = compileRegex False
+    dres = mapM go spDesc
+    ores = combineErrors $ fmap (mapM go) spOther
 
-compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex)
+compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
 compileRegex groups pat = case res of
-  Right re -> Right (pat, re)
-  Left _ -> Left $ RegexError pat
+  Right re -> return (pat, re)
+  Left _ -> throwError $ InsertException [RegexError pat]
   where
     res =
       compile
@@ -632,10 +781,10 @@ compileRegex groups pat = case res of
         (blankExecOpt {captureGroups = groups})
         pat
 
-matchMaybe :: T.Text -> Regex -> EitherErr Bool
+matchMaybe :: T.Text -> Regex -> InsertExcept Bool
 matchMaybe q re = case execute re q of
-  Right res -> Right $ isJust res
-  Left _ -> Left $ RegexError "this should not happen"
+  Right res -> return $ isJust res
+  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
 
 matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
 matchGroupsMaybe q re = case regexec re q of

package.yaml

@@ -86,6 +86,7 @@ dependencies:
 - data-fix
 - filepath
 - mtl
+- persistent-mtl >= 0.3.0.0
 
 library:
   source-dirs: lib/

stack.yaml

@@ -46,6 +46,7 @@ extra-deps:
   commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4
   subdirs: [dhall]
 - hashable-1.3.5.0
+- persistent-mtl-0.3.0.0
 #
 # extra-deps: []