packages feed

megaparsec 6.0.2 → 6.1.0

raw patch · 8 files changed

+122/−26 lines, 8 files

Files

CHANGELOG.md view
@@ -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`.
Text/Megaparsec.hs view
@@ -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 #-}
Text/Megaparsec/Char/Lexer.hs view
@@ -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'
Text/Megaparsec/Error.hs view
@@ -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         [] -> "<empty line>"-        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'
megaparsec.cabal view
@@ -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
tests/Text/Megaparsec/ErrorSpec.hs view
@@ -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 " $
tests/Text/Megaparsec/ExprSpec.hs view
@@ -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 "-")] ]
tests/Text/MegaparsecSpec.hs view
@@ -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'))