Add hint erasing when try backtracks consuming (#243)

CHANGELOG.md

@@ -6,6 +6,11 @@
 * 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

@@ -62,6 +62,7 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE RecordWildCards            #-}
@@ -231,9 +232,17 @@ newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid)
 
 -- | 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@.
@@ -423,7 +432,7 @@ pPlus :: (Ord e, Stream s)
 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
@@ -930,13 +939,13 @@ pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->
   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
@@ -947,7 +956,7 @@ pObserving
   -> 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 #-}
 

tests/Text/MegaparsecSpec.hs

@@ -653,14 +653,21 @@ spec = do
                 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
                 p = try (char a *> char b)
                 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 @@ spec = do
               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'))