From 2b3c97e1aff71bb02306282731a28bfe4b6778ae Mon Sep 17 00:00:00 2001 From: Alex Chen Date: Tue, 25 Sep 2018 13:33:31 -0600 Subject: [PATCH] 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 | 27 +++++++++++++---------- hledger-lib/Hledger/Read/JournalReader.hs | 20 +++++++++-------- hledger-lib/Text/Megaparsec/Custom.hs | 17 ++++++-------- 3 files changed, 33 insertions(+), 31 deletions(-) diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 1cf574f21..2b0a475f2 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/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 - "invalid time (bad hour)" + unless (h' >= 0 && h' <= 23) $ customFailure $ + 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 - "invalid time (bad minute)" + unless (m' >= 0 && m' <= 59) $ customFailure $ + 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 - "invalid time (bad second)" -- we do not support leap seconds + unless (s' >= 0 && s' <= 59) $ customFailure $ + 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 diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index c4024ef15..1a4f1f84c 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/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) - $ parseErrorAt parentpos ("Cyclic include: " ++ filepath) + when (filepath `elem` parentfilestack) $ customFailure $ + 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. diff --git a/hledger-lib/Text/Megaparsec/Custom.hs b/hledger-lib/Text/Megaparsec/Custom.hs index 5dce6f785..804b62ab4 100644 --- a/hledger-lib/Text/Megaparsec/Custom.hs +++ b/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 pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg) -{-# INLINABLE parseErrorAt #-} +parseErrorAt :: SourcePos -> String -> CustomErr +parseErrorAt pos msg = ErrorFailAt pos (sourceColumn pos) msg -- | 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) -{-# INLINABLE parseErrorAtRegion #-} + in ErrorFailAt startPos endCol msg -- | Attach a source file to a parse error. Intended for use with the -- 'region' parser combinator.