diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +## Megaparsec 6.1.0 + +* Improved rendering of offending line in `parseErrorPretty'` in the + presence of tab characters. + +* Added `parseErrorPretty_`, which is just like `parseErrorPretty'` but + allows to specify tab width to use. + +* Adjusted hint generation so when we backtrack a consuming parser with + `try`, we do not create hints from its parse error (because it's further + in input stream!). This was a quite subtle bug that stayed unnoticed for + several years apparently. + ## Megaparsec 6.0.2 * Allow `parser-combinators-0.2.0`. diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -62,6 +62,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -231,9 +232,17 @@ -- | Convert 'ParseError' record into 'Hints'. -toHints :: ParseError t e -> Hints t -toHints (TrivialError _ _ ps) = Hints (if E.null ps then [] else [ps]) -toHints (FancyError _ _) = mempty +toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t +toHints streamPos = \case + TrivialError errPos _ ps -> + -- NOTE This is important to check here that the error indeed has + -- happened at the same position as current position of stream because + -- there might have been backtracking with 'try' and in that case we + -- must not convert such a parse error to hints. + if streamPos == errPos + then Hints (if E.null ps then [] else [ps]) + else mempty + FancyError _ _ -> mempty {-# INLINE toHints #-} -- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. @@ -311,6 +320,8 @@ unParser p s (cok . f) cerr (eok . f) eerr {-# INLINE pMap #-} +-- | 'pure' returns a parser that __succeeds__ without consuming input. + instance Stream s => A.Applicative (ParsecT e s m) where pure = pPure (<*>) = pAp @@ -329,10 +340,14 @@ in unParser m s mcok cerr meok eerr {-# INLINE pAp #-} +-- | 'A.empty' is a parser that __fails__ without consuming input. + instance (Ord e, Stream s) => A.Alternative (ParsecT e s m) where empty = mzero (<|>) = mplus +-- | 'return' returns a parser that __succeeds__ without consuming input. + instance Stream s => Monad (ParsecT e s m) where return = pure (>>=) = pBind @@ -399,6 +414,8 @@ runParsecT p s `catchError` \e -> runParsecT (h e) s +-- | 'mzero' is a parser that __fails__ without consuming input. + instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus @@ -415,7 +432,7 @@ pPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err ms = let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') - neok x s' hs = eok x s' (toHints err <> hs) + neok x s' hs = eok x s' (toHints (statePos s') err <> hs) neerr err' s' = eerr (err' <> err) (longestMatch ms s') in unParser n s cok ncerr neok neerr in unParser m s cok cerr eok meerr @@ -922,13 +939,13 @@ let mcerr err ms = let rcok x s' _ = cok x s' mempty rcerr _ _ = cerr err ms - reok x s' _ = eok x s' (toHints err) + reok x s' _ = eok x s' (toHints (statePos s') err) reerr _ _ = cerr err ms in unParser (r err) ms rcok rcerr reok reerr meerr err ms = - let rcok x s' _ = cok x s' (toHints err) + let rcok x s' _ = cok x s' (toHints (statePos s') err) rcerr _ _ = eerr err ms - reok x s' _ = eok x s' (toHints err) + reok x s' _ = eok x s' (toHints (statePos s') err) reerr _ _ = eerr err ms in unParser (r err) ms rcok rcerr reok reerr in unParser p s cok mcerr eok meerr @@ -939,7 +956,7 @@ -> ParsecT e s m (Either (ParseError (Token s) e) a) pObserving p = ParsecT $ \s cok _ eok _ -> let cerr' err s' = cok (Left err) s' mempty - eerr' err s' = eok (Left err) s' (toHints err) + eerr' err s' = eok (Left err) s' (toHints (statePos s') err) in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs --- a/Text/Megaparsec/Char/Lexer.hs +++ b/Text/Megaparsec/Char/Lexer.hs @@ -91,6 +91,11 @@ -- 'skipBlockComment' or 'skipBlockCommentNested' if you don't need anything -- special. -- +-- If you don't want to allow a kind of comment, simply pass 'empty' which +-- will fail instantly when parsing of that sort of comment is attempted and +-- 'space' will just move on or finish depending on whether there is more +-- white space for it to consume. +-- -- Parsing of white space is an important part of any parser. We propose a -- convention where every lexeme parser assumes no spaces before the lexeme -- and consumes all spaces after the lexeme; this is what the 'lexeme' diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -36,6 +36,7 @@ , ShowErrorComponent (..) , parseErrorPretty , parseErrorPretty' + , parseErrorPretty_ , sourcePosStackPretty , parseErrorTextPretty ) where @@ -293,18 +294,38 @@ -- 'SourcePos'es in 'ParseError', it's up to you to provide correct input -- stream corresponding to the file in which parse error actually happened. -- +-- 'parseErrorPretty'' is defined in terms of the more general +-- 'parseErrorPretty_' function which allows to specify tab width as well: +-- +-- > parseErrorPretty' = parseErrorPretty_ defaultTabWidth +-- -- @since 6.0.0 parseErrorPretty' + :: ( ShowToken (Token s) + , LineToken (Token s) + , ShowErrorComponent e + , Stream s ) + => s -- ^ Original input stream + -> ParseError (Token s) e -- ^ Parse error to render + -> String -- ^ Result of rendering +parseErrorPretty' = parseErrorPretty_ defaultTabWidth + +-- | Just like 'parseErrorPretty'', but allows to specify tab width. +-- +-- @since 6.1.0 + +parseErrorPretty_ :: forall s e. ( ShowToken (Token s) , LineToken (Token s) , ShowErrorComponent e , Stream s ) - => s -- ^ Original input stream + => Pos -- ^ Tab width + -> s -- ^ Original input stream -> ParseError (Token s) e -- ^ Parse error to render -> String -- ^ Result of rendering -parseErrorPretty' s e = +parseErrorPretty_ w s e = sourcePosStackPretty (errorPos e) <> ":\n" <> padding <> "|\n" <> lineNumber <> " | " <> rline <> "\n" <> @@ -318,7 +339,7 @@ rline = case rline' of [] -> "" - xs -> xs + xs -> expandTab w xs rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $ selectLine (sourceLine epos) s @@ -456,3 +477,17 @@ case take1_ s of Nothing -> s Just (_, s') -> s' + +-- | Replace tab characters with given number of spaces. + +expandTab + :: Pos + -> String + -> String +expandTab w' = go 0 + where + go 0 [] = [] + go 0 ('\t':xs) = go w xs + go 0 (x:xs) = x : go 0 xs + go !n xs = ' ' : go (n - 1) xs + w = unPos w' diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -1,5 +1,5 @@ name: megaparsec -version: 6.0.2 +version: 6.1.0 cabal-version: >= 1.18 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license: BSD2 diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs --- a/tests/Text/Megaparsec/ErrorSpec.hs +++ b/tests/Text/Megaparsec/ErrorSpec.hs @@ -230,10 +230,14 @@ "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n" it "shows position on 1000 line correctly" $ do let s = replicate 999 '\n' ++ "abc" - pe :: PE - pe = err (posN 999 s) (utok 'a' <> etok 'd') + pe = err (posN 999 s) (utok 'a' <> etok 'd') :: PE parseErrorPretty' s pe `shouldBe` "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n" + it "shows offending line in the presence of tabs correctly" $ do + let s = "\tsomething" :: String + pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE + parseErrorPretty' s pe `shouldBe` + "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n" context "with Word8 tokens" $ do it "shows empty line correctly" $ do let s = "" :: ByteString @@ -254,6 +258,21 @@ pe = err (posN 999 s) (utok 97 <> etok 100) :: PW parseErrorPretty' s pe `shouldBe` "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n" + it "shows offending line in the presence of tabs correctly" $ do + let s = "\tsomething" :: ByteString + pe = err (posN 1 s) (utok 115 <> etok 120) :: PW + parseErrorPretty' s pe `shouldBe` + "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n" + + describe "parseErrorPretty_" $ + it "takes tab width into account correctly" $ + property $ \w' -> do + let s = "\tsomething\t" :: String + pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE + w = unPos w' + parseErrorPretty_ w' s pe `shouldBe` + ("1:9:\n |\n1 | " ++ replicate w ' ' ++ "something" ++ replicate w ' ' + ++ "\n | ^\nunexpected 's'\nexpecting 'x'\n") describe "sourcePosStackPretty" $ it "result never ends with a newline " $ diff --git a/tests/Text/Megaparsec/ExprSpec.hs b/tests/Text/Megaparsec/ExprSpec.hs --- a/tests/Text/Megaparsec/ExprSpec.hs +++ b/tests/Text/Megaparsec/ExprSpec.hs @@ -14,7 +14,7 @@ import Text.Megaparsec.Expr #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) +import Control.Applicative #endif spec :: Spec @@ -149,11 +149,11 @@ table :: [[Operator Parser Node]] table = - [ [ Prefix (symbol "-" *> pure Neg) - , Postfix (symbol "!" *> pure Fac) - , InfixN (symbol "%" *> pure Mod) ] - , [ InfixR (symbol "^" *> pure Exp) ] - , [ InfixL (symbol "*" *> pure Pro) - , InfixL (symbol "/" *> pure Div) ] - , [ InfixL (symbol "+" *> pure Sum) - , InfixL (symbol "-" *> pure Sub)] ] + [ [ Prefix (Neg <$ symbol "-") + , Postfix (Fac <$ symbol "!") + , InfixN (Mod <$ symbol "%") ] + , [ InfixR (Exp <$ symbol "^") ] + , [ InfixL (Pro <$ symbol "*") + , InfixL (Div <$ symbol "/") ] + , [ InfixL (Sum <$ symbol "+") + , InfixL (Sub <$ symbol "-")] ] diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -653,7 +653,7 @@ s = [a] grs p s (`shouldParse` a) grs' p s (`succeedsLeaving` "") - context "when inner parser fails consuming" $ + context "when inner parser fails consuming" $ do it "backtracks, it appears as if the parser has not consumed anything" $ property $ \a b c -> b /= c ==> do let p :: MonadParsec Void String m => m Char @@ -661,6 +661,13 @@ s = [a,c] grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b)) grs' p s (`failsLeaving` s) + it "hints from the inner parse error do not leak" $ + property $ \a b c -> b /= c ==> do + let p :: MonadParsec Void String m => m (Maybe Char) + p = (optional . try) (char a *> char b) <* empty + s = [a,c] + grs p s (`shouldFailWith` err posI mempty) + grs' p s (`failsLeaving` s) context "when inner parser succeeds without consuming" $ it "try has no effect" $ property $ \a -> do @@ -892,8 +899,8 @@ r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a')) | a == 0 && b == 0 && c > 3 = f (err posI (utok 'c' <> etok 'a')) | a == 0 && b == 0 = f (err posI (utok 'c' <> etok 'a')) - | a == 0 && b > 3 = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'a' <> etok 'c')) - | a == 0 && c == 0 = f (err (posN b s) (ueof <> etok 'a' <> etok 'c')) + | a == 0 && b > 3 = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'c')) + | a == 0 && c == 0 = f (err (posN b s) (ueof <> etok 'c')) | a == 0 && c > 3 = f (err (posN (b + 3) s) (utok 'c' <> eeof)) | a == 0 = z (Left (err posI (utok 'b' <> etok 'a'))) | a > 3 = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))