WIP cancel transactions on error

app/Main.hs

@@ -161,4 +161,5 @@ runSync c = do
     flip runReaderT (s $ takeDirectory c) $ do
       insertBudget $ budget config
       insertStatements config
-    showBalances
+
+-- showBalances

lib/Internal/Statement.hs

@@ -23,18 +23,12 @@ import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
-readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
+readImport :: MonadUnliftIO m => Import -> MappingT m StatementRes
 readImport Import {..} = do
   rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
-  case matchRecords impMatches rs of
-    Right (ts, es, notfound) -> do
-      liftIO $ mapM_ putStrLn $ reverse es
-      liftIO $ mapM_ print notfound
-      return ts
-    Left e -> do
-      liftIO $ print e
-      -- TODO make sure that a blank list results in a cache reset in the db
-      return []
+  -- TODO show more useful information here (eg which file emitted this
+  -- error and possibly where)
+  return $ matchRecords impMatches rs
 
 readImport_
   :: MonadUnliftIO m
@@ -67,19 +61,15 @@ parseTxRecord TxOpts {..} r = do
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os
 
-matchRecords :: [Match] -> [TxRecord] -> PureErr ([BalTx], [String], [Match])
-matchRecords ms rs = do
-  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
-  let (es, ts) =
-        partitionEithers $
-          fmap Just . balanceTx <$> catMaybes matched
-  let bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
-  return
-    ( catMaybes ts
-    , T.unpack <$> (es ++ bu)
-    , -- TODO record number of times each match hits for debugging
-      notfound
-    )
+matchRecords :: [Match] -> [TxRecord] -> StatementRes
+matchRecords ms rs = case matchAll (matchPriorities ms) rs of
+  Left e -> StatementFail $ StatementErrors [] [] [e]
+  Right (matched, unmatched, notfound) ->
+    -- TODO record number of times each match hits for debugging
+    let (errors, matched_) = partitionEithers $ balanceTx <$> matched
+     in case (matched_, unmatched, notfound, errors) of
+          (xs, [], [], []) -> StatementPass xs
+          (_, us, ns, es) -> StatementFail $ StatementErrors us ns es
 
 matchPriorities :: [Match] -> [MatchGroup]
 matchPriorities =
@@ -156,7 +146,7 @@ matchDec m@Match {mTimes = t} =
   where
     t' = fmap pred t
 
-matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
+matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -166,16 +156,21 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
+matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match])
 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)
 
-matchDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
+matchDates :: [Match] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match])
 matchDates ms = go ([], [], initZipper ms)
   where
-    go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
+    go (matched, unmatched, z) [] =
+      Right
+        ( catMaybes matched
+        , reverse unmatched
+        , recoverZipper z
+        )
     go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
       Left zipped -> go (matched, r : unmatched, zipped) rs
       Right unzipped -> do
@@ -187,10 +182,15 @@ matchDates ms = go ([], [], initZipper ms)
         go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
 
-matchNonDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
+matchNonDates :: [Match] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match])
 matchNonDates ms = go ([], [], initZipper ms)
   where
-    go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
+    go (matched, unmatched, z) [] =
+      Right
+        ( catMaybes matched
+        , reverse unmatched
+        , recoverZipper z
+        )
     go (matched, unmatched, z) (r : rs) = do
       (z', res) <- zipperMatch' z r
       let (m, u) = case res of
@@ -199,12 +199,12 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> Either T.Text BalTx
+balanceTx :: RawTx -> PureErr BalTx
 balanceTx t@Tx {txSplits = ss} = do
   bs <- balanceSplits ss
   return $ t {txSplits = bs}
 
-balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
+balanceSplits :: [RawSplit] -> PureErr [BalSplit]
 balanceSplits ss =
   fmap concat
     <$> mapM (uncurry bal)

lib/Internal/Types.hs

@@ -506,3 +506,16 @@ type BalTx = Tx BalSplit
 type PureErr a = Either T.Text a
 
 data MatchRes a = MatchPass a | MatchFail | MatchSkip
+
+data InsertException = MatchException | RegexException deriving (Show)
+
+-- TODO retain file information here for clearer printing purposes
+data StatementErrors = StatementErrors
+  { seUnmatched :: [TxRecord]
+  , seNotFound :: [Match]
+  , seErrors :: [T.Text]
+  }
+
+data StatementRes = StatementPass [BalTx] | StatementFail StatementErrors
+
+instance Exception InsertException