app/Main.hs

@@ -2,12 +2,8 @@
 
 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
@@ -107,7 +103,7 @@ sync =
 parse :: Options -> IO ()
 parse (Options c Reset) = do
   config <- readConfig c
-  runDB (sqlConfig config) nukeTables
+  migrate_ (sqlConfig config) nukeTables
 parse (Options c DumpAccounts) = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies) = runDumpCurrencies c
@@ -159,31 +155,19 @@ runDumpAccountKeys c = do
     t3 (_, _, x) = x
     double x = (x, x)
 
-runSync :: FilePath -> IO ()
+runSync :: MonadUnliftIO m => FilePath -> m ()
 runSync c = do
   config <- readConfig c
-  let (hTs, hSs) = splitHistory $ statements config
+  handle err $ migrate_ (sqlConfig config) $ do
-  pool <- runNoLoggingT $ mkPool $ sqlConfig config
+    res <- getDBState config
-  handle err $ do
+    case res of
-    -- _ <- askLoggerIO
+      Left es -> throwIO $ InsertException es
-
+      Right s -> do
-    -- get the current DB state
+        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
-    s <- runSqlQueryT pool $ do
+        es1 <- concat <$> mapM (run . insertBudget) (budget config)
-      runMigration migrateAll
+        es2 <- run $ insertStatements config
-      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+        let es = es1 ++ es2
-
+        unless (null es) $ throwIO $ InsertException es
-    -- 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,7 +29,6 @@ library
       Internal.Database.Ops
       Internal.Insert
       Internal.Statement
-      Internal.TH
       Internal.Types
       Internal.Utils
   other-modules:
@@ -89,7 +88,6 @@ library
     , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
-    , persistent-mtl >=0.3.0.0
     , persistent-sqlite
     , recursion-schemes
     , regex-tdfa
@@ -159,7 +157,6 @@ 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

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

lib/Internal/Database/Ops.hs

@@ -1,26 +1,21 @@
 module Internal.Database.Ops
-  ( runDB
+  ( migrate_
   , 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.Esqueleto.Experimental
-import qualified Database.Esqueleto.Experimental as E
+import Database.Persist.Sql hiding (delete, (==.), (||.))
-import Database.Esqueleto.Internal.Internal (SqlSelect)
+import Database.Persist.Sqlite hiding (delete, (==.), (||.))
-import Database.Persist.Monad
+import Database.Sqlite hiding (Config)
--- 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
@@ -31,27 +26,31 @@ import qualified RIO.Map as M
 import qualified RIO.NonEmpty as N
 import qualified RIO.Text as T
 
-runDB
+migrate_
   :: MonadUnliftIO m
   => SqlConfig
-  -> SqlQueryT (NoLoggingT m) a
+  -> SqlPersistT (ResourceT (NoLoggingT m)) ()
-  -> m a
+  -> m ()
-runDB c more =
+migrate_ c more =
-  runNoLoggingT $ do
+  runNoLoggingT $
-    pool <- mkPool c
+    runResourceT $
-    runSqlQueryT pool $ do
+      withSqlConn
-      _ <- lift askLoggerIO
+        (openConnection c)
+        ( \backend ->
+            flip runSqlConn backend $ do
+              _ <- askLoggerIO
               runMigration migrateAll
               more
+        )
 
-mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
+openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
-mkPool c = case c of
+openConnection c logfn = case c of
-  Sqlite p -> createSqlitePool p 10
+  Sqlite p -> liftIO $ do
-  -- conn <- open p
+    conn <- open p
-  -- wrapConnection conn logfn
+    wrapConnection conn logfn
   Postgres -> error "postgres not implemented"
 
-nukeTables :: MonadSqlQuery m => m ()
+nukeTables :: MonadUnliftIO m => SqlPersistT m ()
 nukeTables = do
   deleteWhere ([] :: [Filter CommitR])
   deleteWhere ([] :: [Filter CurrencyR])
@@ -99,8 +98,8 @@ hashConfig
     } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
     where
       (ms, ps) = partitionEithers $ fmap go ss
-      go (HistTransfer x) = Left x
+      go (StmtManual x) = Left x
-      go (HistStatement x) = Right x
+      go (StmtImport x) = Right x
 
 setDiff :: Eq a => [a] -> [a] -> ([a], [a])
 -- setDiff = setDiff' (==)
@@ -119,67 +118,99 @@ setDiff as bs = (as \\ bs, bs \\ as)
 --       | f a b = Just bs
 --       | otherwise = inB a bs
 
-getDBHashes :: MonadSqlQuery m => m [Int]
+getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
 getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
 
-nukeDBHash :: MonadSqlQuery m => Int -> m ()
+nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
-nukeDBHash h = deleteE $ do
+nukeDBHash h = delete $ do
-  c <- E.from E.table
+  c <- from table
-  E.where_ (c ^. CommitRHash ==. E.val h)
+  where_ (c ^. CommitRHash ==. val h)
 
-nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
+nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
+getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
 getConfigHashes c = do
   let ch = hashConfig c
   dh <- getDBHashes
   return $ setDiff dh ch
 
-dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
+updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
-dumpTbl = selectE $ E.from E.table
+updateHashes c = do
+  (del, new) <- getConfigHashes c
+  nukeDBHashes del
+  return new
 
-deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
+dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
-deleteAccount e = deleteE $ do
+dumpTbl = select $ from table
-  c <- E.from $ E.table @AccountR
+
-  E.where_ (c ^. AccountRId ==. E.val k)
+deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
+deleteAccount e = delete $ do
+  c <- from $ table @AccountR
+  where_ (c ^. AccountRId ==. val k)
   where
     k = entityKey e
 
-deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
+deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
-deleteCurrency e = deleteE $ do
+deleteCurrency e = delete $ do
-  c <- E.from $ E.table @CurrencyR
+  c <- from $ table @CurrencyR
-  E.where_ (c ^. CurrencyRId ==. E.val k)
+  where_ (c ^. CurrencyRId ==. val k)
   where
     k = entityKey e
 
-deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
+deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
-deleteTag e = deleteE $ do
+deleteTag e = delete $ do
-  c <- E.from $ E.table @TagR
+  c <- from $ table @TagR
-  E.where_ (c ^. TagRId ==. E.val k)
+  where_ (c ^. TagRId ==. 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
-  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
+  :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
   => Entity r
-  -> m ()
+  -> ReaderT b 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, curPrecision} =
+currency2Record c@Currency {curSymbol, curFullname} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
+  Entity (toKey c) $ CurrencyR curSymbol curFullname
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
-currencyMap =
+currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
-  M.fromList
+
-    . fmap
+updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
-      ( \e ->
+updateTags cs = do
-          ( currencyRSymbol $ entityVal e
+  let tags = fmap toRecord cs
-          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
+  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))
 
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
@@ -286,81 +317,26 @@ indexAcntRoot r =
     (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
 
 getDBState
-  :: (MonadInsertError m, MonadSqlQuery m)
+  :: MonadUnliftIO m
   => Config
-  -> m (FilePath -> DBState)
+  -> SqlPersistT m (EitherErrs (FilePath -> DBState))
 getDBState c = do
-  (del, new) <- getConfigHashes c
+  am <- updateAccounts $ accounts c
+  cm <- updateCurrencies $ currencies c
+  ts <- updateTags $ tags c
+  hs <- updateHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
-  combineError bi si $ \b s f ->
+  return $ concatEither2 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 = currencyMap cs
+      { kmCurrency = cm
       , kmAccount = am
       , kmBudgetInterval = b
       , kmStatementInterval = s
-      , kmNewCommits = new
+      , kmNewCommits = hs
-      , kmOldCommits = del
       , kmConfigDir = f
-      , kmTag = tagMap ts
+      , kmTag = ts
-      , kmTagAll = ts
-      , kmAcntPaths = paths
-      , kmAcntsOld = acnts
-      , kmCurrenciesOld = cs
       }
   where
-    bi = liftExcept $ resolveBounds $ budgetInterval $ global c
+    bi = resolveBounds $ budgetInterval $ global c
-    si = liftExcept $ resolveBounds $ statementInterval $ global c
+    si = 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,8 +5,6 @@ module Internal.Statement
   )
 where
 
-import Control.Monad.Error.Class
-import Control.Monad.Except
 import Data.Csv
 import Internal.Types
 import Internal.Utils
@@ -20,33 +18,32 @@ import RIO.Time
 import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
+
-readImport Statement {..} = do
+readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
-  let ores = compileOptions stmtTxOpts
+readImport Import {..} = do
-  let cres = combineErrors $ compileMatch <$> stmtParsers
+  let ores = plural $ compileOptions impTxOpts
-  (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
+  let cres = concatEithersL $ compileMatch <$> impMatches
-  let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
+  case concatEithers2 ores cres (,) of
-  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
+    Right (compiledOptions, compiledMatches) -> do
-  m <- askDBState kmCurrency
+      ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
-  fromEither $
+      case concatEitherL ires of
-    flip runReader m $
+        Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
-      runExceptT $
+        Left es -> return $ Left es
-        matchRecords compiledMatches records
+    Left es -> return $ Left es
 
 readImport_
-  :: (MonadUnliftIO m, MonadFinance m)
+  :: MonadFinance m
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
-  -> m [TxRecord]
+  -> m (EitherErr [TxRecord])
 readImport_ n delim tns p = do
   dir <- askDBState kmConfigDir
-  res <- tryIO $ BL.readFile $ dir </> p
+  bs <- liftIO $ BL.readFile $ dir </> p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Left m -> return $ Left $ ParseError $ T.pack m
-    Right (_, v) -> return $ catMaybes $ V.toList v
+    Right (_, v) -> return $ Right $ catMaybes $ V.toList v
   where
     opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
     skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@@ -65,25 +62,27 @@ parseTxRecord p TxOpts {..} r = do
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
+matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [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
-    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+      matched_ <- first (: []) $ mapM balanceTx ms_
-    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
+      Right matched_
+    (_, us, ns) -> Left [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
   fmap matchToGroup
-    . L.groupBy (\a b -> spPriority a == spPriority b)
+    . L.groupBy (\a b -> mPriority a == mPriority b)
-    . L.sortOn (Down . spPriority)
+    . L.sortOn (Down . mPriority)
 
 matchToGroup :: [MatchRe] -> MatchGroup
 matchToGroup ms =
   uncurry MatchGroup $
-    first (L.sortOn spDate) $
+    first (L.sortOn mDate) $
-      L.partition (isJust . spDate) ms
+      L.partition (isJust . mDate) ms
 
 -- TDOO could use a better struct to flatten the maybe date subtype
 data MatchGroup = MatchGroup
@@ -125,13 +124,10 @@ zipperSlice f x = go
         EQ -> goEq $ Unzipped bs (a : cs) as
         LT -> z
 
-zipperMatch
+zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
-  :: Unzipped MatchRe
-  -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
-    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
+    go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
     go prev (m : ms) = do
       res <- matches m x
       case res of
@@ -139,30 +135,25 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
         skipOrPass ->
           let ps = reverse prev
               ms' = maybe ms (: ms) (matchDec m)
-           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
+           in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
--- TODO all this unpacking left/error crap is annoying
+zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
-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 ->
+        skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
-          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
+    go z' = Right (z', MatchFail)
-    go z' = return (z', MatchFail)
 
 matchDec :: MatchRe -> Maybe MatchRe
-matchDec m = case spTimes m of
+matchDec m = case mTimes m of
   Just 1 -> Nothing
-  Just n -> Just $ m {spTimes = Just $ n - 1}
+  Just n -> Just $ m {mTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -172,17 +163,17 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([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) . spTimes) $ ud ++ un)
+  return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      return
+      Right
         ( catMaybes matched
         , reverse unmatched
         , recoverZipper z
@@ -193,17 +184,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) $ spDate m
+    findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      return
+      Right
         ( catMaybes matched
         , reverse unmatched
         , recoverZipper z
@@ -216,26 +207,26 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> InsertExcept BalTx
+balanceTx :: RawTx -> EitherErr BalTx
 balanceTx t@Tx {txSplits = ss} = do
   bs <- balanceSplits ss
   return $ t {txSplits = bs}
 
-balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
+balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
 balanceSplits ss =
   fmap concat
     <$> mapM (uncurry bal)
     $ groupByKey
-    $ fmap (\s -> (eCurrency s, s)) ss
+    $ fmap (\s -> (sCurrency s, s)) ss
   where
-    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
+    hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
-    haeValue s = Left s
+    hasValue s = Left s
     bal cur rss
-      | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
+      | length rss < 2 = Left $ BalanceError TooFewSplits cur rss
-      | otherwise = case partitionEithers $ fmap haeValue rss of
+      | otherwise = case partitionEithers $ fmap hasValue rss of
-          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
+          ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
-          ([], val) -> return val
+          ([], val) -> Right val
-          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
+          _ -> Left $ BalanceError NotOneBlank cur rss
 
 groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
 groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

lib/Internal/TH.hs

@@ -1,12 +0,0 @@
-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,12 +1,10 @@
 {-# 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
@@ -14,7 +12,6 @@ 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
@@ -28,131 +25,109 @@ import Text.Regex.TDFA
 -------------------------------------------------------------------------------
 
 makeHaskellTypesWith
-  (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
+  (defaultGenerateOptions {generateToDhallInstance = 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 "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
+  , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
-  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
+  , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
-  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
+  , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
+  , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
   , 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 "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
+  , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
   , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
   , 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 "Decimal" "D" "(./dhall/Types.dhall).Decimal"
+  , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
+  , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
+  , -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
+    -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-  , 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"
+    -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
-  ]
+    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
-
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
-deriveProduct
+  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
-  ["Eq", "Show", "Generic", "FromDhall"]
+  , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
-  [ "Currency"
+  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
-  , "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 :(
@@ -169,56 +144,57 @@ 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
-  { bgtLabel :: Text
+  { budgetLabel :: Text
-  , bgtIncomes :: [Income]
+  , incomes :: [Income]
-  , bgtPretax :: [MultiAllocation PretaxValue]
+  , pretax :: [IntervalAllocation]
-  , bgtTax :: [MultiAllocation TaxValue]
+  , tax :: [IntervalAllocation]
-  , bgtPosttax :: [MultiAllocation PosttaxValue]
+  , posttax :: [IntervalAllocation]
-  , bgtTransfers :: [BudgetTransfer]
+  , transfers :: [Transfer]
-  , bgtShadowTransfers :: [ShadowTransfer]
+  , shadowTransfers :: [ShadowTransfer]
   }
 
-deriving instance Hashable PretaxValue
+deriving instance Eq Budget
 
-deriving instance Hashable TaxBracket
+deriving instance Generic Budget
-
-deriving instance Hashable TaxProgression
-
-deriving instance Hashable TaxMethod
-
-deriving instance Hashable TaxValue
-
-deriving instance Hashable PosttaxValue
 
 deriving instance Hashable Budget
 
-deriving instance Hashable BudgetTransferValue
+deriving instance FromDhall Budget
 
-deriving instance Hashable BudgetTransferType
+deriving instance Show TaggedAcnt
+
+deriving instance Eq TaggedAcnt
 
 deriving instance Hashable TaggedAcnt
 
@@ -227,61 +203,70 @@ deriving instance Ord TaggedAcnt
 type CurID = T.Text
 
 data Income = Income
-  { incGross :: Double
+  { incGross :: Decimal
   , incCurrency :: CurID
   , incWhen :: DatePat
-  , incPretax :: [SingleAllocation PretaxValue]
+  , incPretax :: [Allocation]
-  , incTaxes :: [SingleAllocation TaxValue]
+  , incTaxes :: [Allocation]
-  , incPosttax :: [SingleAllocation PosttaxValue]
+  , incPosttax :: [Allocation]
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
-  , incPayPeriod :: !Period
   }
 
-deriving instance Hashable HourlyPeriod
+deriving instance Eq Income
 
-deriving instance Hashable PeriodType
+deriving instance Generic Income
-
-deriving instance Hashable Period
 
 deriving instance Hashable Income
 
-deriving instance (Ord w, Ord v) => Ord (Amount w v)
+deriving instance FromDhall Income
 
-deriving instance Generic (Amount w v)
+deriving instance Show Amount
 
-deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
+deriving instance Eq Amount
 
-deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
+deriving instance Ord Amount
 
--- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
+deriving instance Hashable Amount
 
-deriving instance (Show w, Show v) => Show (Amount w v)
+deriving instance Show Exchange
 
-deriving instance (Eq w, Eq v) => Eq (Amount w v)
+deriving instance Eq Exchange
 
 deriving instance Hashable Exchange
 
+deriving instance Show BudgetCurrency
+
+deriving instance Eq BudgetCurrency
+
 deriving instance Hashable BudgetCurrency
 
-data Allocation w v = Allocation
+data Allocation_ a = Allocation_
   { alloTo :: TaggedAcnt
-  , alloAmts :: [Amount w v]
+  , alloAmts :: [a]
-  , alloCur :: CurID
+  , alloCur :: BudgetCurrency
   }
-  deriving (Eq, Show, Generic, Hashable)
+  deriving (Show)
 
-instance Bifunctor Amount where
+type Allocation = Allocation_ Amount
-  bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
 
-instance Bifunctor Allocation where
+deriving instance Eq Allocation
-  bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
 
-deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
+deriving instance Generic Allocation
 
-type MultiAllocation = Allocation Interval
+deriving instance Hashable Allocation
 
-type SingleAllocation = Allocation ()
+deriving instance FromDhall Allocation
+
+type IntervalAllocation = Allocation_ IntervalAmount
+
+deriving instance Eq IntervalAllocation
+
+deriving instance Generic IntervalAllocation
+
+deriving instance Hashable IntervalAllocation
+
+deriving instance FromDhall IntervalAllocation
 
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
@@ -293,35 +278,98 @@ 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)]
 
--- this is necessary since dhall will reverse the order when importing
+deriving instance Show AmountType
-instance Ord Interval where
-  compare
-    Interval {intStart = s0, intEnd = e0}
-    Interval {intStart = s1, intEnd = e1} =
-      compare (s0, e0) (s1, e1)
 
-data Transfer a c w v = Transfer
+deriving instance Eq AmountType
-  { transFrom :: a
+
-  , transTo :: a
+deriving instance Ord AmountType
-  , transAmounts :: [Amount w v]
+
-  , transCurrency :: c
+deriving instance Hashable AmountType
+
+data TimeAmount a = TimeAmount
+  { taWhen :: a
+  , taAmt :: Amount
+  , taAmtType :: AmountType
   }
-  deriving (Eq, Show)
+  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 instance Hashable ShadowTransfer
 
+deriving instance Eq AcntSet
+
 deriving instance Hashable AcntSet
 
-deriving instance Hashable TransferMatcher
+deriving instance Eq ShadowMatch
 
-deriving instance Hashable ValMatcher
+deriving instance Hashable ShadowMatch
 
-deriving instance Hashable YMDMatcher
+deriving instance Eq MatchVal
 
-deriving instance Hashable DateMatcher
+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
 
 -- TODO this just looks silly...but not sure how to simplify it
-instance Ord YMDMatcher where
+instance Ord MatchYMD 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'
@@ -336,13 +384,21 @@ gregM :: Gregorian -> GregorianM
 gregM Gregorian {gYear = y, gMonth = m} =
   GregorianM {gmYear = y, gmMonth = m}
 
-instance Ord DateMatcher where
+instance Ord MatchDate 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 Hashable EntryNumGetter
+deriving instance Eq SplitNum
+
+deriving instance Hashable SplitNum
+
+deriving instance Show SplitNum
+
+deriving instance Eq Manual
+
+deriving instance Hashable Manual
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -375,10 +431,10 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 data Config_ a = Config_
-  { global :: !TemporalScope
+  { global :: !Global
   , budget :: ![Budget]
   , currencies :: ![Currency]
-  , statements :: ![History]
+  , statements :: ![Statement]
   , accounts :: !a
   , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
@@ -412,30 +468,23 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-type HistTransfer = Transfer AcntID CurID DatePat Double
+data Statement
+  = StmtManual !Manual
+  | StmtImport !Import
+  deriving (Eq, Hashable, Generic, FromDhall)
 
-deriving instance Generic HistTransfer
+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 Hashable HistTransfer
+type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
 
-deriving instance FromDhall HistTransfer
+instance FromDhall ExpSplit
-
-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
@@ -444,7 +493,7 @@ data Tx s = Tx
   }
   deriving (Generic)
 
-type ExpTx = Tx EntryGetter
+type ExpTx = Tx ExpSplit
 
 instance FromDhall ExpTx
 
@@ -458,74 +507,66 @@ data TxOpts re = TxOpts
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Statement = Statement
+data Import = Import
-  { stmtPaths :: ![FilePath]
+  { impPaths :: ![FilePath]
-  , stmtParsers :: ![StatementParser T.Text]
+  , impMatches :: ![Match T.Text]
-  , stmtDelim :: !Word
+  , impDelim :: !Word
-  , stmtTxOpts :: !(TxOpts T.Text)
+  , impTxOpts :: !(TxOpts T.Text)
-  , stmtSkipLines :: !Natural
+  , impSkipLines :: !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 EntryTextGetter t
+data SplitText 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 = EntryTextGetter CurID
+type SplitCur = SplitText CurID
 
-type SplitAcnt = EntryTextGetter AcntID
+type SplitAcnt = SplitText AcntID
 
-deriving instance (Show k, Show v) => Show (Field k v)
+data Field k v = Field
-
+  { fKey :: !k
-deriving instance (Eq k, Eq v) => Eq (Field k v)
+  , fVal :: !v
-
+  }
-deriving instance Generic (Field k v)
+  deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
-
-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 FieldMatcher re
+data MatchOther re
   = Desc !(Field T.Text re)
-  | Val !(Field T.Text ValMatcher)
+  | Val !(Field T.Text MatchVal)
   deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
 
-deriving instance Show (FieldMatcher T.Text)
+deriving instance Show (MatchOther T.Text)
 
-data TxGetter = TxGetter
+data ToTx = ToTx
-  { tgCurrency :: !SplitCur
+  { ttCurrency :: !SplitCur
-  , tgAcnt :: !SplitAcnt
+  , ttPath :: !SplitAcnt
-  , tgEntries :: ![EntryGetter]
+  , ttSplit :: ![ExpSplit]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data StatementParser re = StatementParser
+data Match re = Match
-  { spDate :: !(Maybe DateMatcher)
+  { mDate :: !(Maybe MatchDate)
-  , spVal :: !ValMatcher
+  , mVal :: !MatchVal
-  , spDesc :: !(Maybe re)
+  , mDesc :: !(Maybe re)
-  , spOther :: ![FieldMatcher re]
+  , mOther :: ![MatchOther re]
-  , spTx :: !(Maybe TxGetter)
+  , mTx :: !(Maybe ToTx)
-  , spTimes :: !(Maybe Natural)
+  , mTimes :: !(Maybe Natural)
-  , spPriority :: !Integer
+  , mPriority :: !Integer
   }
   deriving (Eq, Generic, Hashable, FromDhall, Functor)
 
-deriving instance Show (StatementParser T.Text)
+deriving instance Show (Match T.Text)
 
 --------------------------------------------------------------------------------
 -- DATABASE MODEL
@@ -541,7 +582,6 @@ CommitR sql=commits
 CurrencyR sql=currencies
     symbol T.Text
     fullname T.Text
-    precision Int
     deriving Show Eq
 TagR sql=tags
     symbol T.Text
@@ -604,7 +644,7 @@ instance PersistField ConfigType where
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
-type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
+type CurrencyMap = M.Map CurID CurrencyRId
 
 type TagMap = M.Map TagID TagRId
 
@@ -615,17 +655,12 @@ 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 CurrencyM = Reader CurrencyMap
+type MappingT m = ReaderT DBState (SqlPersistT m)
 
-type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
+type KeySplit = Split AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
 
@@ -633,11 +668,12 @@ type TreeR = Tree ([T.Text], AccountRId)
 
 type Balances = M.Map AccountRId Rational
 
-type BalanceM = ReaderT (MVar Balances)
+type BalanceM m = ReaderT (MVar Balances) m
 
-type MonadFinance = MonadReader DBState
+class MonadUnliftIO m => MonadFinance m where
+  askDBState :: (DBState -> a) -> m a
 
-askDBState :: MonadFinance m => (DBState -> a) -> m a
+instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
   askDBState = asks
 
 class MonadUnliftIO m => MonadBalance m where
@@ -717,9 +753,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
+type RawSplit = Split AcntID (Maybe Rational) CurID TagID
 
-type BalSplit = Entry AcntID Rational CurID TagID
+type BalSplit = Split AcntID Rational CurID TagID
 
 type RawTx = Tx RawSplit
 
@@ -761,23 +797,19 @@ data InsertError
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
   | BalanceError !BalanceType !CurID ![RawSplit]
-  | IncomeError !Day !T.Text !Rational
+  | IncomeError !DatePat
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
-  | PeriodError !Day !Day
   deriving (Show)
 
-newtype InsertException = InsertException [InsertError]
+newtype InsertException = InsertException [InsertError] deriving (Show)
-  deriving (Show, Semigroup) via [InsertError]
 
 instance Exception InsertException
 
-type MonadInsertError = MonadError InsertException
+type EitherErr = Either InsertError
 
-type InsertExceptT = ExceptT InsertException
+type EitherErrs = Either [InsertError]
-
-type InsertExcept = InsertExceptT Identity
 
 data XGregorian = XGregorian
   { xgYear :: !Int
@@ -786,11 +818,11 @@ data XGregorian = XGregorian
   , xgDayOfWeek :: !Int
   }
 
-type MatchRe = StatementParser (T.Text, Regex)
+type MatchRe = Match (T.Text, Regex)
 
 type TxOptsRe = TxOpts (T.Text, Regex)
 
-type FieldMatcherRe = FieldMatcher (T.Text, Regex)
+type MatchOtherRe = MatchOther (T.Text, Regex)
 
-instance Show (StatementParser (T.Text, Regex)) where
+instance Show (Match (T.Text, Regex)) where
   show = show . fmap fst

lib/Internal/Utils.hs

@@ -1,6 +1,5 @@
 module Internal.Utils
   ( compareDate
-  , fromWeekday
   , inBounds
   , expandBounds
   , fmtRational
@@ -8,33 +7,16 @@ module Internal.Utils
   , fromGregorian'
   , resolveBounds
   , resolveBounds_
-  , liftInner
+  , leftToMaybe
-  , liftExceptT
+  , dec2Rat
-  , liftExcept
+  , concatEithers2
-  , liftIOExcept
+  , concatEithers3
-  , liftIOExceptT
+  , concatEither3
-  , combineError
+  , concatEither2
-  , combineError_
+  , concatEitherL
-  , combineError3
+  , concatEithersL
-  , combineErrors
+  , concatEither2M
-  , mapErrors
+  , concatEithers2M
-  , combineErrorM
-  , combineErrorM3
-  , combineErrorIO2
-  , combineErrorIO3
-  , combineErrorIOM2
-  , combineErrorIOM3
-  , collectErrorsIO
-  , mapErrorsIO
-  -- , leftToMaybe
-  -- , concatEithers2
-  -- , concatEithers3
-  -- , concatEither3
-  -- , concatEither2
-  -- , concatEitherL
-  -- , concatEithersL
-  -- , concatEither2M
-  -- , concatEithers2M
   , parseRational
   , showError
   , unlessLeft_
@@ -50,19 +32,14 @@ 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
@@ -78,16 +55,6 @@ 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)
@@ -130,22 +97,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
 
 data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
 
-fromYMDMatcher :: YMDMatcher -> YMD_
+fromMatchYMD :: MatchYMD -> YMD_
-fromYMDMatcher m = case m of
+fromMatchYMD m = case m of
   Y y -> Y_ $ fromIntegral y
   YM g -> uncurry YM_ $ gregMTup g
   YMD g -> uncurry3 YMD_ $ gregTup g
 
-compareDate :: DateMatcher -> Day -> Ordering
+compareDate :: MatchDate -> Day -> Ordering
 compareDate (On md) x =
-  case fromYMDMatcher md of
+  case fromMatchYMD 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 fromYMDMatcher md of
+  case fromMatchYMD md of
     Y_ y' -> compareRange y' y
     YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
     YMD_ y' m' d' ->
@@ -165,17 +132,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup
 inBounds :: (Day, Day) -> Day -> Bool
 inBounds (d0, d1) x = d0 <= x && x < d1
 
-resolveBounds :: Interval -> InsertExcept Bounds
+resolveBounds :: Interval -> EitherErr Bounds
 resolveBounds i@Interval {intStart = s} =
   resolveBounds_ (s {gYear = gYear s + 50}) i
 
-resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
+resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
 resolveBounds_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of
-    Nothing -> return $ toBounds $ fromGregorian' def
+    Nothing -> Right $ toBounds $ fromGregorian' def
     Just e_
-      | s_ < e_ -> return $ toBounds e_
+      | s_ < e_ -> Right $ toBounds e_
-      | otherwise -> throwError $ InsertException [BoundsError s e]
+      | otherwise -> Left $ BoundsError s e
   where
     s_ = fromGregorian' s
     toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
@@ -186,193 +153,103 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
+matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
 matches
-  StatementParser {spTx, spOther, spVal, spDate, spDesc}
+  Match {mTx, mOther, mVal, mDate, mDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    res <- liftInner $
+    res <- concatEither3 val other desc $ \x y z -> x && y && z
-      combineError3 val other desc $
+    if date && res
-        \x y z -> x && y && z && date
+      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
-    if res
+      else Right MatchFail
-      then maybe (return MatchSkip) convert spTx
-      else return MatchFail
     where
-      val = valMatches spVal trAmount
+      val = valMatches mVal trAmount
-      date = maybe True (`dateMatches` trDate) spDate
+      date = maybe True (`dateMatches` trDate) mDate
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
+      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
-      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
+      desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
-      convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
+      convert (ToTx cur a ss) = toTx cur a ss r
 
-toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
+toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
-toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
+toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
-  combineError3 acntRes curRes ssRes $ \a c ss ->
+  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
-          Entry
+          Split
-            { eAcnt = a
+            { sAcnt = a_
-            , eCurrency = c
+            , sCurrency = c_
-            , eValue = Just trAmount
+            , sValue = Just trAmount
-            , eComment = ""
+            , sComment = ""
-            , eTags = [] -- TODO what goes here?
+            , sTags = [] -- TODO what goes here?
             }
      in Tx
           { txDate = trDate
           , txDescr = trDesc
-          , txSplits = fromSplit : ss
+          , txSplits = fromSplit : ss_
           }
   where
-    acntRes = liftInner $ resolveAcnt r sa
+    acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
-    curRes = liftInner $ resolveCurrency r sc
+    ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
-    ssRes = combineErrors $ fmap (resolveEntry r) toSplits
 
-valMatches :: ValMatcher -> Rational -> InsertExcept Bool
+valMatches :: MatchVal -> Rational -> EitherErr Bool
-valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
+valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
-  | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
+  | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
-      return $
+      Right $
-        checkMaybe (s ==) vmSign
+        checkMaybe (s ==) mvSign
-          && checkMaybe (n ==) vmNum
+          && checkMaybe (n ==) mvNum
-          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
+          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
   where
     (n, d) = properFraction $ abs x
-    p = 10 ^ vmPrec
+    p = 10 ^ mvPrec
     s = signum x >= 0
     checkMaybe = maybe True
 
-dateMatches :: DateMatcher -> Day -> Bool
+dateMatches :: MatchDate -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
-otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
+otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr 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
 
-resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
+resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
-resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
-  m <- ask
+  concatEithers2 acRes valRes $
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+    \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
-    v' <- mapM (roundPrecisionCur c m) v
-    return $ s {eAcnt = a, eValue = v', eCurrency = c}
   where
-    acntRes = resolveAcnt r eAcnt
+    acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
-    curRes = resolveCurrency r eCurrency
+    valRes = plural $ mapM (resolveValue r) v
-    valRes = mapM (resolveValue r) eValue
 
-liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
+resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
-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) -> readDouble =<< lookupErr SplitValField t (trOther r)
+  (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
-  (ConstN c) -> return c
+  (ConstN c) -> Right $ dec2Rat c
-  -- TODO don't coerce to rational in trAmount
+  AmountN -> Right $ trAmount r
-  AmountN -> return $ fromRational $ trAmount r
 
-resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
+resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
 resolveAcnt = resolveSplitField AcntField
 
-resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
+resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
 resolveCurrency = resolveSplitField CurField
 
-resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
+resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
 resolveSplitField t TxRecord {trOther = o} s = case s of
-  ConstT p -> return p
+  ConstT p -> Right p
-  LookupT f -> lookup_ f o
+  LookupT f -> plural $ lookup_ f o
-  MapT (Field f m) -> do
+  MapT (Field f m) -> plural $ do
     k <- lookup_ f o
     lookup_ k m
   Map2T (Field (f1, f2) m) -> do
-    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
+    (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
-    lookup_ (k1, k2) m
+    plural $ lookup_ (k1, k2) m
   where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
     lookup_ = lookupErr (SplitIDField t)
 
-lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
+lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
 lookupErr what k m = case M.lookup k m of
-  Just x -> return x
+  Just x -> Right x
-  _ -> throwError $ InsertException [LookupError what $ showT k]
+  _ -> Left $ LookupError what $ showT k
 
 parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
 parseRational (pat, re) s = case matchGroupsMaybe s re of
@@ -401,12 +278,7 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
       k <- readSign sign
       return (k, w)
 
-readDouble :: T.Text -> InsertExcept Double
+readRational :: T.Text -> EitherErr Rational
-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
@@ -418,7 +290,7 @@ readRational s = case T.split (== '.') s of
   _ -> err
   where
     readT = readMaybe . T.unpack
-    err = throwError $ InsertException [ConversionError s]
+    err = Left $ ConversionError s
 
 -- TODO smells like a lens
 -- mapTxSplits :: (a -> b) -> Tx a -> Tx b
@@ -435,16 +307,11 @@ 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
 
-roundPrecision :: Natural -> Double -> Rational
+dec2Rat :: Decimal -> Rational
-roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
+dec2Rat D {sign, whole, decimal, precision} =
+  k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
   where
-    p = 10 ^ n
+    k = if sign then 1 else -1
-
-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)
@@ -504,24 +371,8 @@ showError other = case other of
       idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
-  (IncomeError day name balance) ->
+  (IncomeError dp) ->
-    [ T.unwords
+    [T.append "Income allocations exceed total: datepattern=" $ showT dp]
-        [ "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
@@ -551,32 +402,32 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       ]
 
 showMatch :: MatchRe -> T.Text
-showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
+showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
     kvs =
-      [ ("date", showDateMatcher <$> spDate)
+      [ ("date", showMatchDate <$> d)
-      , ("val", showValMatcher spVal)
+      , ("val", showMatchVal v)
-      , ("desc", fst <$> spDesc)
+      , ("desc", fst <$> e)
       , ("other", others)
-      , ("counter", Just $ maybe "Inf" showT spTimes)
+      , ("counter", Just $ maybe "Inf" showT n)
-      , ("priority", Just $ showT spPriority)
+      , ("priority", Just $ showT p)
       ]
-    others = case spOther of
+    others = case o 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)
-showDateMatcher :: DateMatcher -> T.Text
+showMatchDate :: MatchDate -> T.Text
-showDateMatcher md = case md of
+showMatchDate md = case md of
-  (On x) -> showYMDMatcher x
+  (On x) -> showMatchYMD x
-  (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
+  (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
     where
       -- TODO not DRY (this shifting thing happens during the comparison
       -- function (kinda)
-      end = case fromYMDMatcher start of
+      end = case fromMatchYMD start of
         Y_ y -> Y_ $ y + fromIntegral n
         YM_ y m ->
           let (y_, m_) = divMod (m + fromIntegral n - 1) 12
@@ -588,8 +439,8 @@ showDateMatcher md = case md of
                 fromGregorian y m d
 
 -- | convert YMD match to text
-showYMDMatcher :: YMDMatcher -> T.Text
+showMatchYMD :: MatchYMD -> T.Text
-showYMDMatcher = showYMD_ . fromYMDMatcher
+showMatchYMD = showYMD_ . fromMatchYMD
 
 showYMD_ :: YMD_ -> T.Text
 showYMD_ md =
@@ -600,19 +451,19 @@ showYMD_ md =
       YM_ y m -> [fromIntegral y, m]
       YMD_ y m d -> [fromIntegral y, m, d]
 
-showValMatcher :: ValMatcher -> Maybe T.Text
+showMatchVal :: MatchVal -> Maybe T.Text
-showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
+showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
+showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
   Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
-      [ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
+      [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
-      , ("numerator", showT <$> vmNum)
+      , ("numerator", showT <$> mvNum)
-      , ("denominator", showT <$> vmDen)
+      , ("denominator", showT <$> mvDen)
-      , ("precision", Just $ showT vmPrec)
+      , ("precision", Just $ showT mvPrec)
       ]
 
-showMatchOther :: FieldMatcherRe -> T.Text
+showMatchOther :: MatchOtherRe -> T.Text
 showMatchOther (Desc (Field f (re, _))) =
   T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
 showMatchOther (Val (Field f mv)) =
@@ -620,15 +471,15 @@ showMatchOther (Val (Field f mv)) =
     [ "val field"
     , singleQuote f
     , "with match value"
-    , singleQuote $ fromMaybe "*" $ showValMatcher mv
+    , singleQuote $ fromMaybe "*" $ showMatchVal mv
     ]
 
 showSplit :: RawSplit -> T.Text
-showSplit Entry {eAcnt, eValue, eComment} =
+showSplit Split {sAcnt = a, sValue = v, sComment = c} =
   keyVals
-    [ ("account", eAcnt)
+    [ ("account", a)
-    , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
+    , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
-    , ("comment", doubleQuote eComment)
+    , ("comment", doubleQuote c)
     ]
 
 singleQuote :: T.Text -> T.Text
@@ -649,51 +500,51 @@ showT = T.pack . show
 --------------------------------------------------------------------------------
 -- pure error processing
 
--- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
+concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
--- concatEither2 a b fun = case (a, b) of
+concatEither2 a b fun = case (a, b) of
---   (Right a_, Right b_) -> Right $ fun a_ b_
+  (Right a_, Right b_) -> Right $ fun a_ b_
---   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe 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 :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
--- concatEither2M a b fun = case (a, b) of
+concatEither2M a b fun = case (a, b) of
---   (Right a_, Right b_) -> Right <$> fun a_ b_
+  (Right a_, Right b_) -> Right <$> fun a_ b_
---   _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe 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 :: 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
+concatEither3 a b c fun = case (a, b, c) of
---   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
+  (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
---   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
+  _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
 
--- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
+concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
--- concatEithers2 a b = merge . concatEither2 a b
+concatEithers2 a b = merge . concatEither2 a b
 
--- concatEithers2M
+concatEithers2M
---   :: Monad m
+  :: Monad m
---   => Either [x] a
+  => Either [x] a
---   -> Either [x] b
+  -> Either [x] b
---   -> (a -> b -> m c)
+  -> (a -> b -> m c)
---   -> m (Either [x] c)
+  -> m (Either [x] c)
--- concatEithers2M a b = fmap merge . concatEither2M a b
+concatEithers2M a b = fmap merge . concatEither2M a b
 
--- concatEithers3
+concatEithers3
---   :: Either [x] a
+  :: Either [x] a
---   -> Either [x] b
+  -> Either [x] b
---   -> Either [x] c
+  -> Either [x] c
---   -> (a -> b -> c -> d)
+  -> (a -> b -> c -> d)
---   -> Either [x] d
+  -> Either [x] d
--- concatEithers3 a b c = merge . concatEither3 a b c
+concatEithers3 a b c = merge . concatEither3 a b c
 
--- concatEitherL :: [Either x a] -> Either [x] [a]
+concatEitherL :: [Either x a] -> Either [x] [a]
--- concatEitherL as = case partitionEithers as of
+concatEitherL as = case partitionEithers as of
---   ([], bs) -> Right bs
+  ([], bs) -> Right bs
---   (es, _) -> Left es
+  (es, _) -> Left es
 
--- concatEithersL :: [Either [x] a] -> Either [x] [a]
+concatEithersL :: [Either [x] a] -> Either [x] [a]
--- concatEithersL = merge . concatEitherL
+concatEithersL = merge . concatEitherL
 
--- leftToMaybe :: Either a b -> Maybe a
+leftToMaybe :: Either a b -> Maybe a
--- leftToMaybe (Left a) = Just a
+leftToMaybe (Left a) = Just a
--- leftToMaybe _ = Nothing
+leftToMaybe _ = Nothing
 
 unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
 unlessLeft (Left es) _ = return (return es)
@@ -709,11 +560,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 :: Either a b -> Either [a] b
--- plural = first (: [])
+plural = first (: [])
 
--- merge :: Either [[a]] b -> Either [a] b
+merge :: Either [[a]] b -> Either [a] b
--- merge = first concat
+merge = first concat
 
 --------------------------------------------------------------------------------
 -- random functions
@@ -757,23 +608,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 -> InsertExcept TxOptsRe
+compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe
 compileOptions o@TxOpts {toAmountFmt = pat} = do
   re <- compileRegex True pat
   return $ o {toAmountFmt = re}
 
-compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
+compileMatch :: Match T.Text -> EitherErrs MatchRe
-compileMatch m@StatementParser {spDesc, spOther} = do
+compileMatch m@Match {mDesc = d, mOther = os} = do
-  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
+  let dres = plural $ mapM go d
+  let ores = concatEitherL $ fmap (mapM go) os
+  concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
   where
     go = compileRegex False
-    dres = mapM go spDesc
-    ores = combineErrors $ fmap (mapM go) spOther
 
-compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
+compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex)
 compileRegex groups pat = case res of
-  Right re -> return (pat, re)
+  Right re -> Right (pat, re)
-  Left _ -> throwError $ InsertException [RegexError pat]
+  Left _ -> Left $ RegexError pat
   where
     res =
       compile
@@ -781,10 +632,10 @@ compileRegex groups pat = case res of
         (blankExecOpt {captureGroups = groups})
         pat
 
-matchMaybe :: T.Text -> Regex -> InsertExcept Bool
+matchMaybe :: T.Text -> Regex -> EitherErr Bool
 matchMaybe q re = case execute re q of
-  Right res -> return $ isJust res
+  Right res -> Right $ isJust res
-  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
+  Left _ -> Left $ RegexError "this should not happen"
 
 matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
 matchGroupsMaybe q re = case regexec re q of

package.yaml

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

stack.yaml

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