From ff202b2a8124e8dc523f3b16829f1390bda79a81 Mon Sep 17 00:00:00 2001 From: mrkkrp Date: Wed, 28 Jun 2017 16:36:24 +0700 Subject: [PATCH] Allow unmergeable errors --- Text/Megaparsec.hs | 54 ++++++++++++++++------------ Text/Megaparsec/Error.hs | 47 +++++++++++++++++++----- Text/Megaparsec/Lexer.hs | 3 +- tests/Test/Hspec/Megaparsec.hs | 21 +++++++---- tests/Test/Hspec/Megaparsec/AdHoc.hs | 1 + tests/Text/MegaparsecSpec.hs | 27 ++++++++------ 6 files changed, 105 insertions(+), 48 deletions(-) diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs index 0f234388..74da81b0 100644 --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -228,10 +228,10 @@ withHints :: Ord (Token s) -> ParseError (Token s) e -- ^ First argument of resulting continuation -> State s -- ^ Second argument of resulting continuation -> m b -withHints (Hints ps') c e@(ParseError pos us ps xs) = +withHints (Hints ps') c e@(ParseError pos us ps xs o) = if E.null us && E.null ps && not (E.null xs) then c e - else c (ParseError pos us (E.unions (ps : ps')) xs) + else c (ParseError pos us (E.unions (ps : ps')) xs o) {-# INLINE withHints #-} -- | @accHints hs c@ results in “OK” continuation that will add given hints @@ -340,7 +340,7 @@ instance Stream s => Fail.MonadFail (ParsecT e s m) where pFail :: String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos E.empty E.empty d) s + eerr (ParseError pos E.empty E.empty d True) s where d = E.singleton (ErrorFail msg) {-# INLINE pFail #-} @@ -386,7 +386,7 @@ instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where pZero :: ParsecT e s m a pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos E.empty E.empty E.empty) s + eerr (ParseError pos E.empty E.empty E.empty False) s {-# INLINE pZero #-} pPlus :: (Ord e, Stream s) @@ -558,11 +558,14 @@ initialState name s = State class (Stream s, A.Alternative m, MonadPlus m) => MonadParsec e s m | m -> e s where - -- | The most general way to stop parsing and report a 'ParseError'. + -- | The most general way to stop parsing and report a 'ParseError'. The + -- fourth argument allows to mark the error message as overriding, so it + -- will replace parse errors from other branches instead of being merged + -- with them. -- -- 'unexpected' is defined in terms of this function: -- - -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty + -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty False -- -- @since 6.0.0 @@ -570,6 +573,7 @@ class (Stream s, A.Alternative m, MonadPlus m) :: Set (ErrorItem (Token s)) -- ^ Unexpected items -> Set (ErrorItem (Token s)) -- ^ Expected items -> Set (ErrorFancy e) -- ^ Fancy error components + -> Bool -- ^ Whether to override errors from other branches -> m a -- | The parser @label name p@ behaves as parser @p@, but whenever the @@ -754,9 +758,10 @@ pFailure :: Set (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> Set (ErrorFancy e) + -> Bool -> ParsecT e s m a -pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos us ps xs) s +pFailure us ps xs o = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> + eerr (ParseError pos us ps xs o) s {-# INLINE pFailure #-} pLabel :: String -> ParsecT e s m a -> ParsecT e s m a @@ -785,7 +790,7 @@ pLookAhead p = ParsecT $ \s _ cerr eok eerr -> pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (uncons input) - unexpect u = ParseError pos (E.singleton u) E.empty E.empty + unexpect u = ParseError pos (E.singleton u) E.empty E.empty False cok' _ _ _ = eerr (unexpect what) s cerr' _ _ = eok () s mempty eok' _ _ _ = eerr (unexpect what) s @@ -832,7 +837,8 @@ pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> { errorPos = apos:|z , errorUnexpected = (E.singleton . Tokens . nes) x , errorExpected = E.singleton EndOfInput - , errorFancy = E.empty } + , errorFancy = E.empty + , errorOverride = False } (State input (apos:|z) tp w) {-# INLINE pEof #-} @@ -848,13 +854,14 @@ pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> { errorPos = pos:|z , errorUnexpected = E.singleton EndOfInput , errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtoken - , errorFancy = E.empty } s + , errorFancy = E.empty + , errorOverride = False } s Just (c,cs) -> let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c in case test c of Left (us, ps, xs) -> apos `seq` eerr - (ParseError (apos:|z) us ps xs) + (ParseError (apos:|z) us ps xs False) (State input (apos:|z) tp w) Right x -> let newstate = State cs (npos:|z) (tp + 1) w @@ -873,7 +880,8 @@ pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> { errorPos = pos' , errorUnexpected = E.singleton u , errorExpected = (E.singleton . Tokens . NE.fromList) tts - , errorFancy = E.empty } + , errorFancy = E.empty + , errorOverride = False } go _ [] is rs = let ris = reverse is (npos, tp') = foldl' @@ -921,7 +929,7 @@ nes x = x :| [] {-# INLINE nes #-} instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (L.StateT m) = L.StateT $ label n . m try (L.StateT m) = L.StateT $ try . m lookAhead (L.StateT m) = L.StateT $ \s -> @@ -939,7 +947,7 @@ instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (S.StateT m) = S.StateT $ label n . m try (S.StateT m) = S.StateT $ try . m lookAhead (S.StateT m) = S.StateT $ \s -> @@ -957,7 +965,7 @@ instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (L.ReaderT m) = L.ReaderT $ label n . m try (L.ReaderT m) = L.ReaderT $ try . m lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m @@ -972,7 +980,7 @@ instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (L.WriterT m) = L.WriterT $ label n m try (L.WriterT m) = L.WriterT $ try m lookAhead (L.WriterT m) = L.WriterT $ @@ -990,7 +998,7 @@ instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (S.WriterT m) = S.WriterT $ label n m try (S.WriterT m) = S.WriterT $ try m lookAhead (S.WriterT m) = S.WriterT $ @@ -1008,7 +1016,7 @@ instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) try (L.RWST m) = L.RWST $ \r s -> try (m r s) lookAhead (L.RWST m) = L.RWST $ \r s -> do @@ -1028,7 +1036,7 @@ instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) wher updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) try (S.RWST m) = S.RWST $ \r s -> try (m r s) lookAhead (S.RWST m) = S.RWST $ \r s -> do @@ -1048,7 +1056,7 @@ instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) wher updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (IdentityT m) where - failure us ps xs = lift (failure us ps xs) + failure us ps xs o = lift (failure us ps xs o) label n (IdentityT m) = IdentityT $ label n m try = IdentityT . try . runIdentityT lookAhead (IdentityT m) = IdentityT $ lookAhead m @@ -1086,7 +1094,7 @@ infix 0 -- unexpected item @item@ without consuming any input. unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a -unexpected item = failure (E.singleton item) E.empty E.empty +unexpected item = failure (E.singleton item) E.empty E.empty False {-# INLINE unexpected #-} -- | Return both the result of a parse and the list of tokens that were @@ -1121,7 +1129,7 @@ region f m = do Left err -> do let ParseError {..} = f err updateParserState $ \st -> st { statePos = errorPos } - failure errorUnexpected errorExpected errorFancy + failure errorUnexpected errorExpected errorFancy errorOverride Right x -> return x ---------------------------------------------------------------------------- diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs index 69abd950..30c1a85a 100644 --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -104,14 +104,30 @@ instance NFData a => NFData (ErrorFancy a) where -- 'ParseError's, the longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. -- +-- Megaparsec 6 allows to work with “overriding” errors by setting +-- 'errorOverride' to 'True'. Such an overriding error will win over any +-- non-overriding errors from alternative branches of parsing without being +-- merged with them. If two overriding errors are to be merged, the error on +-- the left hand side wins. +-- -- __Note__ changes in version 6.0.0: @errorCustom@ record selector has been -- dropped and 'errorFancy' record selector has been added. data ParseError t e = ParseError - { errorPos :: NonEmpty SourcePos -- ^ Stack of source positions - , errorUnexpected :: Set (ErrorItem t) -- ^ Unexpected items - , errorExpected :: Set (ErrorItem t) -- ^ Expected items - , errorFancy :: Set (ErrorFancy e) -- ^ Fancier errors + { errorPos :: NonEmpty SourcePos + -- ^ Stack of source positions + , errorUnexpected :: Set (ErrorItem t) + -- ^ Unexpected items + , errorExpected :: Set (ErrorItem t) + -- ^ Expected items + , errorFancy :: Set (ErrorFancy e) + -- ^ Fancier errors + -- + -- @since 6.0.0 + , errorOverride :: Bool + -- ^ Whether the error should override other error instead of merging + -- + -- @since 6.0.0 } deriving (Show, Read, Eq, Data, Typeable, Generic) instance (NFData t, NFData e) => NFData (ParseError t e) @@ -121,7 +137,12 @@ instance (Ord t, Ord e) => Semigroup (ParseError t e) where {-# INLINE (<>) #-} instance (Ord t, Ord e) => Monoid (ParseError t e) where - mempty = ParseError (initialPos "" :| []) E.empty E.empty E.empty + mempty = ParseError + { errorPos = initialPos "" :| [] + , errorUnexpected = E.empty + , errorExpected = E.empty + , errorFancy = E.empty + , errorOverride = False } mappend = (<>) {-# INLINE mappend #-} @@ -142,15 +163,25 @@ instance ( Show t -- error message is discarded. This may seem counter-intuitive, but -- 'mergeError' is only used to merge error messages of alternative branches -- of parsing and in this case longest match should be preferred. +-- +-- If 'errorOverride' is 'True' in either argument and the positions are +-- equal, that 'ParseError' will be returned unchanged without merging. If +-- the both 'ParseError' are overriding (and the positions are equal), the +-- first one wins. mergeError :: (Ord t, Ord e) => ParseError t e -> ParseError t e -> ParseError t e -mergeError e1@(ParseError s1 u1 p1 x1) e2@(ParseError s2 u2 p2 x2) = +mergeError e1@(ParseError s1 u1 p1 x1 o1) e2@(ParseError s2 u2 p2 x2 o2) = case s1 `compare` s2 of LT -> e2 - EQ -> ParseError s1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2) + EQ -> + case (o1, o2) of + (False, False) -> + ParseError s1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2) o1 + (True, _) -> e1 + (False, True) -> e2 GT -> e1 {-# INLINE mergeError #-} @@ -238,7 +269,7 @@ parseErrorTextPretty , ShowErrorComponent e ) => ParseError t e -- ^ Parse error to render -> String -- ^ Result of rendering -parseErrorTextPretty (ParseError _ us ps xs) = +parseErrorTextPretty (ParseError _ us ps xs _) = if E.null us && E.null ps && E.null xs then "unknown parse error\n" else mconcat diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs index 3abf9744..f21ab925 100644 --- a/Text/Megaparsec/Lexer.hs +++ b/Text/Megaparsec/Lexer.hs @@ -207,7 +207,8 @@ incorrectIndent :: MonadParsec e s m -> Pos -- ^ Reference indentation level -> Pos -- ^ Actual indentation level -> m a -incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x) +incorrectIndent ord ref actual = + failure E.empty E.empty (E.singleton x) False where x = ErrorIndentation ord ref actual diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs index 79976bf1..7fe6c6dc 100644 --- a/tests/Test/Hspec/Megaparsec.hs +++ b/tests/Test/Hspec/Megaparsec.hs @@ -41,6 +41,7 @@ module Test.Hspec.Megaparsec , elabel , eeof , cstm + , override -- * Incremental parsing , failsLeaving , succeedsLeaving @@ -157,7 +158,7 @@ err :: NonEmpty SourcePos -- ^ 'ParseError' position -> EC t e -- ^ Error components -> ParseError t e -- ^ Resulting 'ParseError' -err pos (EC u e c) = ParseError pos u e c +err pos (EC u e c o) = ParseError pos u e c o -- | Initial source position with empty file name. -- @@ -194,15 +195,16 @@ posN n see = f (initialPos "") see n :| [] data EC t e = EC { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items , ecExpected :: Set (ErrorItem t) -- ^ Expected items - , _ecFancy :: Set (ErrorFancy e) -- ^ Custom items + , _ecFancy :: Set (ErrorFancy e) -- ^ Fancy error items + , _ecOverride :: Bool -- ^ Is it an overriding error? } deriving (Eq, Data, Typeable, Generic) instance (Ord t, Ord e) => Semigroup (EC t e) where - (EC u0 e0 c0) <> (EC u1 e1 c1) = - EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1) + (EC u0 e0 c0 o0) <> (EC u1 e1 c1 o1) = + EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1) (o0 || o1) instance (Ord t, Ord e) => Monoid (EC t e) where - mempty = EC E.empty E.empty E.empty + mempty = EC E.empty E.empty E.empty False mappend = (<>) -- | Construct an “unexpected token” error component. @@ -270,7 +272,14 @@ eeof = mempty { ecExpected = E.singleton EndOfInput } -- @since 0.3.0 cstm :: ErrorFancy e -> EC t e -cstm e = EC E.empty E.empty (E.singleton e) +cstm e = EC E.empty E.empty (E.singleton e) False + +-- | Mark the error as overriding. +-- +-- @since 6.0.0 + +override :: EC t e +override = EC E.empty E.empty E.empty True ---------------------------------------------------------------------------- -- Incremental parsing diff --git a/tests/Test/Hspec/Megaparsec/AdHoc.hs b/tests/Test/Hspec/Megaparsec/AdHoc.hs index e9e42d51..cbc9300b 100644 --- a/tests/Test/Hspec/Megaparsec/AdHoc.hs +++ b/tests/Test/Hspec/Megaparsec/AdHoc.hs @@ -208,6 +208,7 @@ instance (Arbitrary t, Ord t, Arbitrary e, Ord e) <*> (E.fromList <$> arbitrary) <*> (E.fromList <$> arbitrary) <*> (E.fromList <$> arbitrary) + <*> arbitrary instance Arbitrary a => Arbitrary (State a) where arbitrary = State diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs index 38984946..1e56dc18 100644 --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -430,7 +430,7 @@ spec = do it "fails signals correct parse error" $ property $ \msg -> do let p = fail msg :: Parsec Void String () - prs p "" `shouldFailWith` err posI (cstm $ ErrorFail msg) + prs p "" `shouldFailWith` err posI (cstm (ErrorFail msg) <> override) it "pure is the same as return" $ property $ \n -> prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" @@ -445,7 +445,7 @@ spec = do it "signals correct parse error" $ property $ \s msg -> do let p = void (fail msg) - prs p s `shouldFailWith` err posI (cstm $ ErrorFail msg) + prs p s `shouldFailWith` err posI (cstm (ErrorFail msg) <> override) prs' p s `failsLeaving` s describe "ParsecT MonadIO instance" $ @@ -518,7 +518,8 @@ spec = do { errorPos = posI , errorUnexpected = E.singleton item , errorExpected = E.empty - , errorFancy = E.empty }) + , errorFancy = E.empty + , errorOverride = False }) describe "match" $ it "return consumed tokens along with the result" $ @@ -542,29 +543,33 @@ spec = do (errorUnexpected e0) (errorExpected e0) (errorFancy e0) + (errorOverride e0) f x = ParseError { errorPos = ((G.<>) `on` errorPos) x e1 , errorUnexpected = (E.union `on` errorUnexpected) x e1 , errorExpected = (E.union `on` errorExpected) x e1 - , errorFancy = (E.union `on` errorFancy) x e1 } + , errorFancy = (E.union `on` errorFancy) x e1 + , errorOverride = ((||) `on` errorOverride) x e1 } r = ParseError { errorPos = finalPos , errorUnexpected = (E.union `on` errorUnexpected) e0 e1 , errorExpected = (E.union `on` errorExpected) e0 e1 - , errorFancy = (E.union `on` errorFancy) e0 e1 } + , errorFancy = (E.union `on` errorFancy) e0 e1 + , errorOverride = ((||) `on` errorOverride) e0 e1 } finalPos = statePos st G.<> errorPos e1 runParser' p st `shouldBe` (st { statePos = finalPos }, Left r) describe "failure" $ it "signals correct parse error" $ - property $ \us ps xs -> do + property $ \us ps xs o -> do let p :: MonadParsec Void String m => m () - p = void (failure us ps xs) + p = void (failure us ps xs o) grs p "" (`shouldFailWith` ParseError { errorPos = posI , errorUnexpected = us , errorExpected = ps - , errorFancy = xs }) + , errorFancy = xs + , errorOverride = o }) describe "label" $ do context "when inner parser succeeds consuming input" $ do @@ -994,7 +999,8 @@ spec = do { errorPos = posI , errorUnexpected = E.singleton (Tokens $ nes a) , errorExpected = E.singleton (Tokens $ nes b) - , errorFancy = E.empty }) + , errorFancy = E.empty + , errorOverride = False }) grs' p s (`failsLeaving` s) context "when stream is empty" $ it "signals correct parse error" $ @@ -1005,7 +1011,8 @@ spec = do { errorPos = posI , errorUnexpected = E.singleton EndOfInput , errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtok - , errorFancy = E.empty }) + , errorFancy = E.empty + , errorOverride = False }) describe "tokens" $ do context "when stream is prefixed with given string" $