ENH use sane error messages when regexps fail

lib/Internal/Statement.hs

@@ -24,19 +24,17 @@ import qualified RIO.Vector as V
 -- TODO this probably won't scale well (pipes?)
 
 readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
-readImport
+readImport Import {..} = do
-  Import
+  rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
-    { impPaths = ps
+  case matchRecords impMatches rs of
-    , impMatches = ms
+    Right (ts, es, notfound) -> do
-    , impTxOpts = ns
-    , impDelim = d
-    , impSkipLines = n
-    } = do
-    rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps
-    let (ts, es, notfound) = matchRecords ms rs
       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 []
 
 readImport_
   :: MonadUnliftIO m
@@ -69,19 +67,19 @@ parseTxRecord TxOpts {..} r = do
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os
 
-matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
+matchRecords :: [Match] -> [TxRecord] -> PureErr ([BalTx], [String], [Match])
-matchRecords ms rs =
+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
     )
-  where
-    (matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
-    (es, ts) =
-      partitionEithers $
-        fmap Just . balanceTx <$> catMaybes matched
-    bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
 
 matchPriorities :: [Match] -> [MatchGroup]
 matchPriorities =
@@ -129,24 +127,28 @@ zipperSlice f x = go
       EQ -> goEq $ Unzipped bs (a : cs) as
       LT -> z
 
-zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
+zipperMatch :: Unzipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
-    go _ [] = (Zipped bs $ cs ++ as, Nothing)
+    go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
-    go prev (m : ms) = case matches m x of
+    go prev (m : ms) = do
-      Nothing -> go (m : prev) ms
+      res <- matches m x
-      res@(Just _) ->
+      case res of
+        MatchFail -> go (m : prev) ms
+        skipOrPass ->
           let ps = reverse prev
               ms' = maybe ms (: ms) (matchDec m)
-         in (Zipped bs $ ps ++ ms' ++ as, res)
+           in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
-zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
+zipperMatch' :: Zipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx)
 zipperMatch' z x = go z
   where
-    go (Zipped bs (a : as)) = case matches a x of
+    go (Zipped bs (a : as)) = do
-      Nothing -> go (Zipped (a : bs) as)
+      res <- matches a x
-      res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
+      case res of
-    go z' = (z', Nothing)
+        MatchFail -> go (Zipped (a : bs) as)
+        skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
+    go z' = Right (z', MatchFail)
 
 matchDec :: Match -> Maybe Match
 matchDec m@Match {mTimes = t} =
@@ -154,46 +156,47 @@ matchDec m@Match {mTimes = t} =
   where
     t' = fmap pred t
 
-matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
+matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
-      (_, []) -> (matched, [], unused)
+      (_, []) -> return (matched, [], unused)
-      ([], _) -> (matched, rs, unused)
+      ([], _) -> return (matched, rs, unused)
-      (g : gs', _) ->
+      (g : gs', _) -> do
-        let (ts, unmatched, us) = matchGroup g rs
+        (ts, unmatched, us) <- matchGroup g rs
-         in go (ts ++ matched, us ++ unused) gs' unmatched
+        go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
+matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
-matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs =
+matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
-  (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
+  (md, rest, ud) <- matchDates ds rs
-  where
+  (mn, unmatched, un) <- matchNonDates ns rest
-    (md, rest, ud) = matchDates ds rs
+  return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
-    (mn, unmatched, un) = matchNonDates ns rest
 
-matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
+matchDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
 matchDates ms = go ([], [], initZipper ms)
   where
-    go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
+    go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
     go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
-      Left res -> go (matched, r : unmatched, res) rs
+      Left zipped -> go (matched, r : unmatched, zipped) rs
-      Right res ->
+      Right unzipped -> do
-        let (z', p) = zipperMatch res r
+        (z', res) <- zipperMatch unzipped r
-            (m, u) = case p of
+        let (m, u) = case res of
-              Just p' -> (p' : matched, unmatched)
+              MatchPass p -> (Just p : matched, unmatched)
-              Nothing -> (matched, r : unmatched)
+              MatchSkip -> (Nothing : matched, unmatched)
-         in go (m, u, z') rs
+              MatchFail -> (matched, r : unmatched)
+        go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
 
-matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
+matchNonDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
 matchNonDates ms = go ([], [], initZipper ms)
   where
-    go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
+    go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
-    go (matched, unmatched, z) (r : rs) =
+    go (matched, unmatched, z) (r : rs) = do
-      let (z', res) = zipperMatch' z r
+      (z', res) <- zipperMatch' z r
-          (m, u) = case res of
+      let (m, u) = case res of
-            Just x -> (x : matched, unmatched)
+            MatchPass p -> (Just p : matched, unmatched)
-            Nothing -> (matched, r : unmatched)
+            MatchSkip -> (Nothing : matched, unmatched)
+            MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
 balanceTx :: RawTx -> Either T.Text BalTx

lib/Internal/Types.hs

@@ -31,7 +31,7 @@ import RIO.Time
 -------------------------------------------------------------------------------
 
 makeHaskellTypesWith
-    (defaultGenerateOptions{generateToDhallInstance = False})
+  (defaultGenerateOptions {generateToDhallInstance = False})
   [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
   , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
   , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@@ -67,6 +67,7 @@ data AccountTree
 TH.makeBaseFunctor ''AccountTree
 
 deriving instance Generic (AccountTreeF a)
+
 deriving instance FromDhall a => FromDhall (AccountTreeF a)
 
 data AccountRoot_ a = AccountRoot_
@@ -90,6 +91,7 @@ type AccountRoot = AccountRoot_ AccountTree
 deriving instance Eq Currency
 
 deriving instance Lift Currency
+
 deriving instance Hashable Currency
 
 type CurID = T.Text
@@ -113,7 +115,7 @@ type ConfigF = Config_ AccountRootF
 type Config = Config_ AccountRoot
 
 unfix :: ConfigF -> Config
-unfix c@Config_{accounts = a} = c{accounts = a'}
+unfix c@Config_ {accounts = a} = c {accounts = a'}
   where
     a' =
       AccountRoot_
@@ -140,48 +142,61 @@ deriving instance Eq TimeUnit
 deriving instance Hashable TimeUnit
 
 deriving instance Eq Weekday
+
 deriving instance Hashable Weekday
 
 deriving instance Eq WeekdayPat
+
 deriving instance Hashable WeekdayPat
 
 deriving instance Show RepeatPat
+
 deriving instance Eq RepeatPat
+
 deriving instance Hashable RepeatPat
 
 deriving instance Show MDYPat
+
 deriving instance Eq 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 :(
 instance Ord Gregorian where
   compare
-        Gregorian{gYear = y, gMonth = m, gDay = d}
+    Gregorian {gYear = y, gMonth = m, gDay = d}
-        Gregorian{gYear = y', gMonth = m', gDay = d'} =
+    Gregorian {gYear = y', gMonth = m', gDay = d'} =
       compare y y'
         <> compare m m'
         <> compare d d'
 
 instance Ord GregorianM where
   compare
-        GregorianM{gmYear = y, gmMonth = m}
+    GregorianM {gmYear = y, gmMonth = m}
-        GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
+    GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
 
 deriving instance Eq ModPat
+
 deriving instance Hashable ModPat
 
 deriving instance Eq CronPat
+
 deriving instance Hashable CronPat
 
 deriving instance Eq DatePat
+
 deriving instance Hashable DatePat
 
 --------------------------------------------------------------------------------
@@ -205,6 +220,7 @@ data Budget = Budget
   deriving (Generic, FromDhall)
 
 deriving instance Eq Tax
+
 deriving instance Hashable Tax
 
 data Amount v = Amount
@@ -222,7 +238,9 @@ data Allocation v = Allocation
   deriving (Eq, Hashable, Generic, FromDhall)
 
 deriving instance Eq Bucket
+
 deriving instance Hashable Bucket
+
 deriving instance Show Bucket
 
 data TimeAmount = TimeAmount
@@ -282,15 +300,21 @@ data Import = Import
   deriving (Hashable, Generic, FromDhall)
 
 deriving instance Eq MatchVal
+
 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
 
 -- TODO this just looks silly...but not sure how to simplify it
@@ -306,8 +330,8 @@ instance Ord MatchYMD where
   compare (YMD g) (YM g') = compare (gregM g) g' <> GT
 
 gregM :: Gregorian -> GregorianM
-gregM Gregorian{gYear = y, gMonth = m} =
+gregM Gregorian {gYear = y, gMonth = m} =
-    GregorianM{gmYear = y, gmMonth = m}
+  GregorianM {gmYear = y, gmMonth = m}
 
 instance Ord MatchDate where
   compare (On d) (On d') = compare d d'
@@ -316,13 +340,14 @@ instance Ord MatchDate where
   compare (In d _) (On d') = compare d d' <> GT
 
 deriving instance Eq SplitNum
+
 deriving instance Hashable SplitNum
+
 deriving instance Show SplitNum
 
-{- | the value of a field in split (text version)
+-- | the value of a field in split (text version)
- can either be a raw (constant) value, a lookup from the record, or a map
+-- can either be a raw (constant) value, a lookup from the record, or a map
- between the lookup and some other value
+-- between the lookup and some other value
--}
 data SplitText t
   = ConstT !t
   | LookupT !T.Text
@@ -366,7 +391,9 @@ data Match = Match
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
 deriving instance Eq TxOpts
+
 deriving instance Hashable TxOpts
+
 deriving instance Show TxOpts
 
 --------------------------------------------------------------------------------
@@ -375,6 +402,7 @@ deriving instance Show TxOpts
 deriving instance Eq Decimal
 
 deriving instance Hashable Decimal
+
 deriving instance Show Decimal
 
 --------------------------------------------------------------------------------
@@ -472,4 +500,9 @@ type RawSplit = Split AcntID (Maybe Rational) CurID
 type BalSplit = Split AcntID Rational CurID
 
 type RawTx = Tx RawSplit
+
 type BalTx = Tx BalSplit
+
+type PureErr a = Either T.Text a
+
+data MatchRes a = MatchPass a | MatchFail | MatchSkip

lib/Internal/Utils.hs

@@ -116,27 +116,32 @@ lookupErr what k m = case M.lookup k m of
   Just x -> x
   _ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k]
 
-matches :: Match -> TxRecord -> Maybe (Maybe RawTx)
+matches :: Match -> TxRecord -> PureErr (MatchRes RawTx)
-matches Match {..} r@TxRecord {..}
+matches Match {..} r@TxRecord {..} = do
-  | allPass = Just $ fmap eval mTx
+  let date = checkMaybe (`dateMatches` trDate) mDate
-  | otherwise = Nothing
+  let val = valMatches mVal trAmount
+  other <- foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
+  desc <- maybe (return True) (matchMaybe trDesc) mDesc
+  return $
+    if date && val && desc && other
+      then maybe MatchSkip (MatchPass . eval) mTx
+      else MatchFail
   where
-    allPass =
-      checkMaybe (`dateMatches` trDate) mDate
-        && valMatches mVal trAmount
-        && checkMaybe (=~ trDesc) mDesc
-        && all (fieldMatches trOther) mOther
     eval (ToTx cur a ss) = toTx cur a ss r
 
--- TODO these error messages are useless
+matchMaybe :: RegexContext Regex query b => query -> T.Text -> PureErr b
-fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool
+matchMaybe q re = first (const msg) $ pureTry $ q =~ re
+  where
+    msg = T.concat ["Could not make regexp from pattern: '", re, "'"]
+
+fieldMatches :: M.Map T.Text T.Text -> MatchOther -> PureErr Bool
 fieldMatches dict m = case m of
-  Val (Field n mv) -> case readRational =<< M.lookup n dict of
+  Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n)
-    (Just v) -> valMatches mv v
+  Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
-    _ -> error "you dummy"
+  where
-  Desc (Field n md) -> case M.lookup n dict of
+    lookup_ n = case M.lookup n dict of
-    (Just d) -> d =~ md
+      Just r -> Right r
-    _ -> error "you dummy"
+      Nothing -> Left $ T.append "Could not find field: " n
 
 checkMaybe :: (a -> Bool) -> Maybe a -> Bool
 checkMaybe = maybe True
@@ -191,6 +196,11 @@ parseRational pat s = case ms of
       k <- readSign sign
       return (k, w)
 
+readRationalMsg :: T.Text -> PureErr Rational
+readRationalMsg t = maybe (Left msg) Right $ readRational t
+  where
+    msg = T.append "Could not convert to rational number: " t
+
 -- TODO don't use a partial function
 readRational :: MonadFail m => T.Text -> m Rational
 readRational s = case TP.splitOn "." s of