lib: tweak custom parse errors

- Don't immediately throw custom parse errors into 'ParsecT'; rather,
  just construct and return them
- This anticipates the re-implementation of an 'ExceptT' layer of the
  parser, which should be able throw custom parse errors

hledger-lib/Hledger/Read/Common.hs

@@ -364,11 +364,11 @@ datep' mYear = do
     endPos <- getPosition
     let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day
 
-    when (sep1 /= sep2) $ parseErrorAtRegion startPos endPos $
+    when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startPos endPos $
       "invalid date (mixing date separators is not allowed): " ++ dateStr
 
     case fromGregorianValid year month day of
-      Nothing -> parseErrorAtRegion startPos endPos $
+      Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
                    "well-formed but invalid date: " ++ dateStr
       Just date -> pure $! date
 
@@ -379,12 +379,12 @@ datep' mYear = do
     case mYear of
       Just year ->
         case fromGregorianValid year (fromIntegral month) day of
-          Nothing -> parseErrorAtRegion startPos endPos $
+          Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
                       "well-formed but invalid date: " ++ dateStr
           Just date -> pure $! date
         where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
 
-      Nothing -> parseErrorAtRegion startPos endPos $
+      Nothing -> customFailure $ parseErrorAtRegion startPos endPos $
         "partial date "++dateStr++" found, but the current year is unknown"
         where dateStr = show month ++ [sep] ++ show day
 
@@ -415,23 +415,24 @@ datetimep' mYear = do
       pos1 <- getPosition
       h' <- twoDigitDecimal <?> "hour"
       pos2 <- getPosition
-      unless (h' >= 0 && h' <= 23) $ parseErrorAtRegion pos1 pos2
+      unless (h' >= 0 && h' <= 23) $ customFailure $
-        "invalid time (bad hour)"
+        parseErrorAtRegion pos1 pos2 "invalid time (bad hour)"
 
       char ':' <?> "':' (hour-minute separator)"
       pos3 <- getPosition
       m' <- twoDigitDecimal <?> "minute"
       pos4 <- getPosition
-      unless (m' >= 0 && m' <= 59) $ parseErrorAtRegion pos3 pos4
+      unless (m' >= 0 && m' <= 59) $ customFailure $
-        "invalid time (bad minute)"
+        parseErrorAtRegion pos3 pos4 "invalid time (bad minute)"
 
       s' <- option 0 $ do
         char ':' <?> "':' (minute-second separator)"
         pos5 <- getPosition
         s' <- twoDigitDecimal <?> "second"
         pos6 <- getPosition
-        unless (s' >= 0 && s' <= 59) $ parseErrorAtRegion pos5 pos6
+        unless (s' >= 0 && s' <= 59) $ customFailure $
-          "invalid time (bad second)" -- we do not support leap seconds
+          parseErrorAtRegion pos5 pos6 "invalid time (bad second)"
+          -- we do not support leap seconds
         pure s'
 
       pure $ TimeOfDay h' m' (fromIntegral s')
@@ -574,7 +575,8 @@ amountwithoutpricep = do
   interpretNumber posRegion suggestedStyle ambiguousNum mExp =
     let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum
     in  case fromRawNumber rawNum mExp of
-          Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg
+          Left errMsg -> customFailure $
+                           uncurry parseErrorAtRegion posRegion errMsg
           Right res -> pure res
 
 -- | Parse an amount from a string, or get an error.
@@ -793,7 +795,8 @@ rawnumberp = label "number" $ do
   mExtraFragment <- optional $ lookAhead $ try $
     char ' ' *> getPosition <* digitChar
   case mExtraFragment of
-    Just pos -> parseErrorAt pos "invalid number (excessive trailing digits)"
+    Just pos -> customFailure $
+                  parseErrorAt pos "invalid number (excessive trailing digits)"
     Nothing -> pure ()
 
   return $ dbg8 "rawnumberp" rawNumber

hledger-lib/Hledger/Read/JournalReader.hs

@@ -195,18 +195,20 @@ includedirectivep = do
         -- Compiling filename as a glob pattern works even if it is a literal
         fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of
             Right x -> pure x
-            Left e -> parseErrorAt parserpos $ "Invalid glob pattern: " ++ e
+            Left e -> customFailure $
+                        parseErrorAt parserpos $ "Invalid glob pattern: " ++ e
         -- Get all matching files in the current working directory, sorting in
         -- lexicographic order to simulate the output of 'ls'.
         filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
         if (not . null) filepaths
             then pure filepaths
-            else parseErrorAt parserpos $ "No existing files match pattern: " ++ filename
+            else customFailure $ parseErrorAt parserpos $
+                   "No existing files match pattern: " ++ filename
 
     parseChild parentpos filepath = do
         parentfilestack <- fmap sourceName . statePos <$> getParserState
-        when (filepath `elem` parentfilestack)
+        when (filepath `elem` parentfilestack) $ customFailure $
-            $ parseErrorAt parentpos ("Cyclic include: " ++ filepath)
+          parseErrorAt parentpos ("Cyclic include: " ++ filepath)
 
         childInput <- lift $ readFilePortably filepath
                              `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
@@ -294,7 +296,7 @@ commoditydirectiveonelinep = do
   _ <- lift followingcommentp
   let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle}
   if asdecimalpoint astyle == Nothing
-  then parseErrorAt pos pleaseincludedecimalpoint
+  then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
   else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
 
 pleaseincludedecimalpoint :: String
@@ -327,9 +329,9 @@ formatdirectivep expectedsym = do
   if acommodity==expectedsym
     then 
       if asdecimalpoint astyle == Nothing
-      then parseErrorAt pos pleaseincludedecimalpoint
+      then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
       else return $ dbg2 "style from format subdirective" astyle
-    else parseErrorAt pos $
+    else customFailure $ parseErrorAt pos $
          printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
 
 keywordp :: String -> JournalParser m ()
@@ -422,7 +424,7 @@ defaultcommoditydirectivep = do
   Amount{acommodity,astyle} <- amountp
   lift restofline
   if asdecimalpoint astyle == Nothing
-  then parseErrorAt pos pleaseincludedecimalpoint
+  then customFailure $ parseErrorAt pos pleaseincludedecimalpoint
   else setDefaultCommodityAndStyle (acommodity, astyle)
 
 marketpricedirectivep :: JournalParser m MarketPrice
@@ -481,7 +483,7 @@ periodictransactionp = do
   (periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp d)
   -- In periodic transactions, the period expression has an additional constraint:
   case checkPeriodicTransactionStartDate interval span periodtxt of
-    Just e -> parseErrorAt pos e
+    Just e -> customFailure $ parseErrorAt pos e
     Nothing -> pure ()
   -- The line can end here, or it can continue with one or more spaces
   -- and then zero or more of the following fields. A bit awkward.

hledger-lib/Text/Megaparsec/Custom.hs

@@ -9,7 +9,7 @@ module Text.Megaparsec.Custom (
   -- * Custom parse error type
   CustomErr,
 
-  -- * Throwing custom parse errors
+  -- * Constructing custom parse errors
   parseErrorAt,
   parseErrorAtRegion,
   withSource,
@@ -60,13 +60,12 @@ instance ShowErrorComponent CustomErr where
   showErrorComponent (ErrorWithSource _ e) = parseErrorTextPretty e
 
 
---- * Throwing custom parse errors
+--- * Constructing custom parse errors
 
 -- | Fail at a specific source position.
 
-parseErrorAt :: MonadParsec CustomErr s m => SourcePos -> String -> m a
+parseErrorAt :: SourcePos -> String -> CustomErr
-parseErrorAt pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg)
+parseErrorAt pos msg = ErrorFailAt pos (sourceColumn pos) msg
-{-# INLINABLE parseErrorAt #-}
 
 -- | Fail at a specific source interval (within a single line). The
 -- interval is inclusive on the left and exclusive on the right; that is,
@@ -74,19 +73,17 @@ parseErrorAt pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg)
 -- end position.
 
 parseErrorAtRegion
-  :: MonadParsec CustomErr s m
+  :: SourcePos -- ^ Start position
-  => SourcePos -- ^ Start position
   -> SourcePos -- ^ End position
   -> String    -- ^ Error message
-  -> m a
+  -> CustomErr
 parseErrorAtRegion startPos endPos msg =
   let startCol = sourceColumn startPos
       endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos
       endCol = if startCol <= endCol'
                     && sourceLine startPos == sourceLine endPos
                then endCol' else startCol
-  in  customFailure (ErrorFailAt startPos endCol msg)
+  in  ErrorFailAt startPos endCol msg
-{-# INLINABLE parseErrorAtRegion #-}
 
 -- | Attach a source file to a parse error. Intended for use with the
 -- 'region' parser combinator.