Skip to content

Commit

Permalink
Allow unmergeable errors
Browse files Browse the repository at this point in the history
  • Loading branch information
@mrkkrp
mrkkrp committed Jun 28, 2017
1 parent 5ed815f commit ff202b2
Show file tree
Hide file tree
Showing 6 changed files with 105 additions and 48 deletions.
54 changes: 31 additions & 23 deletions Text/Megaparsec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 #-}

Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -558,18 +558,22 @@ 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

failure
:: 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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 #-}

Expand All @@ -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
Expand All @@ -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'
Expand Down Expand Up @@ -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 ->
Expand All @@ -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 ->
Expand All @@ -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
Expand All @@ -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 $
Expand All @@ -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 $
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

----------------------------------------------------------------------------
Expand Down
47 changes: 39 additions & 8 deletions Text/Megaparsec/Error.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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 #-}

Expand All @@ -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 #-}

Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion Text/Megaparsec/Lexer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
21 changes: 15 additions & 6 deletions tests/Test/Hspec/Megaparsec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,7 @@ module Test.Hspec.Megaparsec
, elabel
, eeof
, cstm
, override
-- * Incremental parsing
, failsLeaving
, succeedsLeaving
Expand Down Expand Up @@ -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.
--
Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions tests/Test/Hspec/Megaparsec/AdHoc.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading

0 comments on commit ff202b2

Please sign in to comment.