megaparsec 9.3.1 → 9.4.0
raw patch · 10 files changed
+117/−56 lines, 10 files
Files
- CHANGELOG.md +13/−0
- Text/Megaparsec.hs +1/−1
- Text/Megaparsec/Char/Lexer.hs +6/−6
- Text/Megaparsec/Class.hs +16/−0
- Text/Megaparsec/Debug.hs +22/−9
- Text/Megaparsec/Error.hs +3/−0
- Text/Megaparsec/Internal.hs +27/−21
- Text/Megaparsec/Internal.hs-boot +10/−0
- Text/Megaparsec/Stream.hs +18/−18
- megaparsec.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,18 @@ *Megaparsec follows [SemVer](https://semver.org/).* +## Megaparsec 9.4.0++* `dbg` now prints hints among other debug information. [PR+ 530](https://github.com/mrkkrp/megaparsec/pull/530).++* Hints are no longer lost in certain methods of MTL instances for+ `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528).++* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be+ used to construct “new primitives” with arbitrary behavior at the expense+ of having to dive into Megaparsec's internals. [PR+ 514](https://github.com/mrkkrp/megaparsec/pull/514).+ ## Megaparsec 9.3.1 * Fixed a bug related to processing of tabs when error messages are
Text/Megaparsec.hs view
@@ -288,7 +288,7 @@ bundlePosState = statePosState s } return $ case result of- OK x ->+ OK _ x -> case NE.nonEmpty (stateParseErrors s') of Nothing -> (s', Right x) Just de -> (s', Left (toBundle de))
Text/Megaparsec/Char/Lexer.hs view
@@ -258,9 +258,9 @@ let lvl = fromMaybe pos indent x <- if- | pos <= ref -> incorrectIndent GT ref pos- | pos == lvl -> p- | otherwise -> incorrectIndent EQ lvl pos+ | pos <= ref -> incorrectIndent GT ref pos+ | pos == lvl -> p+ | otherwise -> incorrectIndent EQ lvl pos xs <- indentedItems ref lvl sc p f (x : xs) {-# INLINEABLE indentBlock #-}@@ -288,9 +288,9 @@ then return [] else if- | pos <= ref -> return []- | pos == lvl -> (:) <$> p <*> go- | otherwise -> incorrectIndent EQ lvl pos+ | pos <= ref -> return []+ | pos == lvl -> (:) <$> p <*> go+ | otherwise -> incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/
Text/Megaparsec/Class.hs view
@@ -37,6 +37,7 @@ import qualified Control.Monad.Trans.Writer.Strict as S import Data.Set (Set) import Text.Megaparsec.Error+import {-# SOURCE #-} Text.Megaparsec.Internal (Reply) import Text.Megaparsec.State import Text.Megaparsec.Stream @@ -272,6 +273,13 @@ -- | @'updateParserState' f@ applies the function @f@ to the parser state. updateParserState :: (State s e -> State s e) -> m () + -- | An escape hatch for defining custom 'MonadParsec' primitives. You+ -- will need to import "Text.Megaparsec.Internal" in order to construct+ -- 'Reply'.+ --+ -- @since 9.4.0+ mkParsec :: (State s e -> Reply e s a) -> m a+ ---------------------------------------------------------------------------- -- Lifting through MTL @@ -295,6 +303,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) instance (MonadParsec e s m) => MonadParsec e s (S.StateT st m) where parseError e = lift (parseError e)@@ -316,6 +325,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) instance (MonadParsec e s m) => MonadParsec e s (L.ReaderT r m) where parseError e = lift (parseError e)@@ -334,6 +344,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where parseError e = lift (parseError e)@@ -359,6 +370,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where parseError e = lift (parseError e)@@ -384,6 +396,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) -- | @since 5.2.0 instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where@@ -408,6 +421,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) -- | @since 5.2.0 instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where@@ -432,6 +446,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift (updateParserState f)+ mkParsec f = lift (mkParsec f) instance (MonadParsec e s m) => MonadParsec e s (IdentityT m) where parseError e = lift (parseError e)@@ -451,6 +466,7 @@ takeP l n = lift (takeP l n) getParserState = lift getParserState updateParserState f = lift $ updateParserState f+ mkParsec f = lift (mkParsec f) fixs :: s -> Either a (b, s) -> (Either a b, s) fixs s (Left a) = (Left a, s)
Text/Megaparsec/Debug.hs view
@@ -31,8 +31,10 @@ import qualified Control.Monad.Trans.Writer.Lazy as L import qualified Control.Monad.Trans.Writer.Strict as S import Data.Bifunctor (Bifunctor (first))+import qualified Data.List as List import qualified Data.List.NonEmpty as NE import Data.Proxy+import qualified Data.Set as E import Debug.Trace import Text.Megaparsec.Class (MonadParsec) import Text.Megaparsec.Error@@ -214,7 +216,7 @@ show (ShowComment lbl (a, c)) = show a ++ " (" ++ lbl ++ ": " ++ show c ++ ")" instance- (VisualStream s, ShowErrorComponent e) =>+ (VisualStream s, ShowErrorComponent e, Monad m) => MonadParsecDbg e s (ParsecT e s m) where dbg lbl p = ParsecT $ \s cok cerr eok eerr ->@@ -223,7 +225,7 @@ cok' x s' hs = flip trace (cok x s' hs) $ l (DbgIn (unfold (stateInput s)))- ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)+ ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x hs) cerr' err s' = flip trace (cerr err s') $ l (DbgIn (unfold (stateInput s)))@@ -231,7 +233,7 @@ eok' x s' hs = flip trace (eok x s' hs) $ l (DbgIn (unfold (stateInput s)))- ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)+ ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x hs) eerr' err s' = flip trace (eerr err s') $ l (DbgIn (unfold (stateInput s)))@@ -241,9 +243,9 @@ -- | A single piece of info to be rendered with 'dbgLog'. data DbgItem s e a = DbgIn [Token s]- | DbgCOK [Token s] a+ | DbgCOK [Token s] a (Hints (Token s)) | DbgCERR [Token s] (ParseError s e)- | DbgEOK [Token s] a+ | DbgEOK [Token s] a (Hints (Token s)) | DbgEERR [Token s] (ParseError s e) -- | Render a single piece of debugging info.@@ -260,15 +262,26 @@ where prefix = unlines . fmap ((lbl ++ "> ") ++) . lines pxy = Proxy :: Proxy s+ showHints hs = "[" ++ List.intercalate "," (showErrorItem pxy <$> E.toAscList hs) ++ "]" msg = case item of DbgIn ts -> "IN: " ++ showStream pxy ts- DbgCOK ts a ->- "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+ DbgCOK ts a (Hints hs) ->+ "MATCH (COK): "+ ++ showStream pxy ts+ ++ "\nVALUE: "+ ++ show a+ ++ "\nHINTS: "+ ++ showHints hs DbgCERR ts e -> "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e- DbgEOK ts a ->- "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+ DbgEOK ts a (Hints hs) ->+ "MATCH (EOK): "+ ++ showStream pxy ts+ ++ "\nVALUE: "+ ++ show a+ ++ "\nHINTS: "+ ++ showHints hs DbgEERR ts e -> "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e
Text/Megaparsec/Error.hs view
@@ -43,6 +43,7 @@ errorBundlePretty, parseErrorPretty, parseErrorTextPretty,+ showErrorItem, ) where @@ -458,6 +459,8 @@ -- Helpers -- | Pretty-print an 'ErrorItem'.+--+-- @since 9.4.0 showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String showErrorItem pxy = \case Tokens ts -> showTokens pxy ts
Text/Megaparsec/Internal.hs view
@@ -95,7 +95,8 @@ -- | All information available after parsing. This includes consumption of -- input, success (with the returned value) or failure (with the parse--- error), and parser state at the end of parsing.+-- error), and parser state at the end of parsing. 'Reply' can also be used+-- to resume parsing. -- -- See also: 'Consumption', 'Result'. data Reply e s a = Reply (State s e) Consumption (Result s e a)@@ -107,15 +108,15 @@ = -- | Some part of input stream was consumed Consumed | -- | No input was consumed- Virgin+ NotConsumed -- | Whether the parser has failed or not. On success we include the -- resulting value, on failure we include a 'ParseError'. -- -- See also: 'Consumption', 'Reply'. data Result s e a- = -- | Parser succeeded- OK a+ = -- | Parser succeeded (includes hints)+ OK (Hints (Token s)) a | -- | Parser failed Error (ParseError s e) @@ -150,7 +151,7 @@ -- | @since 6.3.0 instance- (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) =>+ (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e, Monad m) => IsString (ParsecT e s m a) where fromString s = tokens (==) (fromString s)@@ -248,37 +249,41 @@ instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where ask = lift ask- local f p = mkPT $ \s -> local f (runParsecT p s)+ local f p = mkParsecT $ \s -> local f (runParsecT p s) instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where- callCC f = mkPT $ \s ->+ callCC f = mkParsecT $ \s -> callCC $ \c ->- runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s+ runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s where- pack s a = Reply s Virgin (OK a)+ pack s a = Reply s NotConsumed (OK mempty a) instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError- p `catchError` h = mkPT $ \s ->+ p `catchError` h = mkParsecT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s -mkPT :: (Stream s, Monad m) => (State s e -> m (Reply e s a)) -> ParsecT e s m a-mkPT k = ParsecT $ \s cok cerr eok eerr -> do+mkParsecT ::+ (Stream s, Monad m) =>+ (State s e -> m (Reply e s a)) ->+ ParsecT e s m a+mkParsecT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of- OK x -> cok x s' mempty+ OK hs x -> cok x s' hs Error e -> cerr e s'- Virgin ->+ NotConsumed -> case result of- OK x -> eok x s' mempty+ OK hs x -> eok x s' hs Error e -> eerr e s'+{-# INLINE mkParsecT #-} -- | 'mzero' is a parser that __fails__ without consuming input. --@@ -326,9 +331,9 @@ -- | @since 6.0.0 instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where- mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do+ mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do let a = case result of- OK a' -> a'+ OK _ a' -> a' Error _ -> error "mfix ParsecT" runParsecT (f a) s @@ -336,7 +341,7 @@ lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty -instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where+instance (Ord e, Stream s, Monad m) => MonadParsec e s (ParsecT e s m) where parseError = pParseError label = pLabel try = pTry@@ -352,6 +357,7 @@ takeP = pTakeP getParserState = pGetParserState updateParserState = pUpdateParserState+ mkParsec f = mkParsecT (pure . f) pParseError :: ParseError s e ->@@ -651,10 +657,10 @@ m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr where- cok a s' _ = return $ Reply s' Consumed (OK a)+ cok a s' hs = return $ Reply s' Consumed (OK hs a) cerr err s' = return $ Reply s' Consumed (Error err)- eok a s' _ = return $ Reply s' Virgin (OK a)- eerr err s' = return $ Reply s' Virgin (Error err)+ eok a s' hs = return $ Reply s' NotConsumed (OK hs a)+ eerr err s' = return $ Reply s' NotConsumed (Error err) -- | Transform any custom errors thrown by the parser using the given -- function. Similar in function and purpose to @withExceptT@.
+ Text/Megaparsec/Internal.hs-boot view
@@ -0,0 +1,10 @@+{-# LANGUAGE RoleAnnotations #-}++module Text.Megaparsec.Internal+ ( Reply,+ )+where++type role Reply nominal nominal representational++data Reply e s a
Text/Megaparsec/Stream.hs view
@@ -614,18 +614,18 @@ c' = unPos c w = unPos pstateTabWidth in if- | ch == newlineTok ->- St- (SourcePos n (l <> pos1) pos1)- id- | ch == tabTok ->- St- (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)))- (g . (fromTok ch :))- | otherwise ->- St- (SourcePos n l (c <> pos1))- (g . (fromTok ch :))+ | ch == newlineTok ->+ St+ (SourcePos n (l <> pos1) pos1)+ id+ | ch == tabTok ->+ St+ (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)))+ (g . (fromTok ch :))+ | otherwise ->+ St+ (SourcePos n l (c <> pos1))+ (g . (fromTok ch :)) {-# INLINE reachOffset' #-} -- | Like 'reachOffset'' but for 'reachOffsetNoLine'.@@ -665,12 +665,12 @@ let c' = unPos c w = unPos pstateTabWidth in if- | ch == newlineTok ->- SourcePos n (l <> pos1) pos1- | ch == tabTok ->- SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))- | otherwise ->- SourcePos n l (c <> pos1)+ | ch == newlineTok ->+ SourcePos n (l <> pos1) pos1+ | ch == tabTok ->+ SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))+ | otherwise ->+ SourcePos n l (c <> pos1) {-# INLINE reachOffsetNoLine' #-} -- | Like 'BL.splitAt' but accepts the index as an 'Int'.
megaparsec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: megaparsec-version: 9.3.1+version: 9.4.0 license: BSD-2-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com>