megaparsec 8.0.0 → 9.0.0
raw patch · 22 files changed
+2352/−2069 lines, 22 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- CHANGELOG.md +18/−6
- README.md +3/−3
- Setup.hs +4/−0
- Text/Megaparsec.hs +199/−186
- Text/Megaparsec/Byte.hs +77/−69
- Text/Megaparsec/Byte/Lexer.hs +120/−104
- Text/Megaparsec/Char.hs +104/−103
- Text/Megaparsec/Char/Lexer.hs +207/−169
- Text/Megaparsec/Class.hs +203/−201
- Text/Megaparsec/Common.hs +10/−11
- Text/Megaparsec/Debug.hs +59/−49
- Text/Megaparsec/Error.hs +236/−196
- Text/Megaparsec/Error.hs-boot +1/−1
- Text/Megaparsec/Error/Builder.hs +53/−60
- Text/Megaparsec/Internal.hs +295/−242
- Text/Megaparsec/Lexer.hs +43/−32
- Text/Megaparsec/Pos.hs +30/−32
- Text/Megaparsec/State.hs +48/−42
- Text/Megaparsec/Stream.hs +314/−266
- bench/memory/Main.hs +101/−91
- bench/speed/Main.hs +124/−117
- megaparsec.cabal +103/−89
CHANGELOG.md view
@@ -1,5 +1,17 @@-## Megaparec 8.0.0+## Megaparsec 9.0.0 +* Split the `Stream` type class. The methods `showTokens` and `tokensLength`+ have been put into a separate type class `VisualStream`, while+ `reachOffset` and `reachOffsetNoLine` are now in `TraversableStream`. This+ should make defining `Stream` instances for custom streams easier.++* Defined `Stream` instances for lists and `Seq`s.++* Added the functions `hspace` and `hspace1` to the `Text.Megaparsec.Char`+ and `Text.Megaparsec.Byte` modules.++## Megaparsec 8.0.0+ * The methods `failure` and `fancyFailure` of `MonadParsec` are now ordinary functions and live in `Text.Megaparsec`. They are defined in terms of the new `parseError` method of `MonadParsec`. This method allows us to signal@@ -308,7 +320,7 @@ `Text.Megaparsec.Byte` if you intend to parse binary data, then add qualified modules you need (permutation parsing, lexing, expression parsing, etc.). `Text.Megaparsec.Lexer` was renamed to- `Text.Megaparec.Char.Lexer` because many functions in it has the `Token s+ `Text.Megaparsec.Char.Lexer` because many functions in it has the `Token s ~ Char` constraint. There is also `Text.Megaparsec.Byte.Lexer` now, although it has fewer functions. @@ -401,17 +413,17 @@ * Added `notChar` in `Text.Megaparsec.Char`. -* Added `space1` in `Text.Megaprasec.Char`. This parser is like `space` but+* Added `space1` in `Text.Megaparsec.Char`. This parser is like `space` but requires at least one space character to be present to succeed. * Added new module `Text.Megaparsec.Byte`, which is similar to `Text.Megaparsec.Char`, but for token streams of the type `Word8` instead of `Char`. -* `integer` was dropped from `Text.Megaparec.Char.Lexer`. Use `decimal`+* `integer` was dropped from `Text.Megaparsec.Char.Lexer`. Use `decimal` instead. -* `number` was dropped from `Text.Megaparec.Char.Lexer`. Use `scientific`+* `number` was dropped from `Text.Megaparsec.Char.Lexer`. Use `scientific` instead. * `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return@@ -823,7 +835,7 @@ ### Built-in combinators * All built-in combinators in `Text.Megaparsec.Combinator` now work with any- instance of `Alternative` (some of them even with `Applicaitve`).+ instance of `Alternative` (some of them even with `Applicative`). * Added more powerful `count'` parser. This parser can be told to parse from `m` to `n` occurrences of some thing. `count` is defined in terms of
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/megaparsec) [](http://stackage.org/nightly/package/megaparsec) [](http://stackage.org/lts/package/megaparsec)-[](https://travis-ci.org/mrkkrp/megaparsec)+ * [Features](#features) * [Core features](#core-features)@@ -160,7 +160,7 @@ You can run the benchmarks yourself by executing: ```-$ nix-bulid -A benches.parsers-bench+$ nix-build -A benches.parsers-bench $ cd result/bench $ ./bench-memory $ ./bench-speed@@ -330,7 +330,7 @@ Distributed under FreeBSD license. [hackage]: https://hackage.haskell.org/package/megaparsec-[the-tutorial]: https://markkarpov.com/megaparsec/megaparsec.html+[the-tutorial]: https://markkarpov.com/tutorial/megaparsec.html [hacking]: ./HACKING.md [tm]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec.html
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
Text/Megaparsec.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec -- Copyright : © 2015–present Megaparsec contributors@@ -11,8 +19,7 @@ -- -- This module includes everything you need to get started writing a parser. -- If you are new to Megaparsec and don't know where to begin, take a look--- at the tutorials--- <https://markkarpov.com/learn-haskell.html#megaparsec-tutorials>.+-- at the tutorial <https://markkarpov.com/tutorial/megaparsec.html>. -- -- In addition to the "Text.Megaparsec" module, which exports and re-exports -- most everything that you may need, we advise to import@@ -44,81 +51,79 @@ -- like “Type variable @e0@ is ambiguous …”, you need to give an explicit -- signature to your parser to resolve the ambiguity. It's a good idea to -- provide type signatures for all top-level definitions.--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec ( -- * Re-exports -- $reexports- module Text.Megaparsec.Pos- , module Text.Megaparsec.Error- , module Text.Megaparsec.Stream- , module Control.Monad.Combinators+ module Text.Megaparsec.Pos,+ module Text.Megaparsec.Error,+ module Text.Megaparsec.Stream,+ module Control.Monad.Combinators,+ -- * Data types- , State (..)- , PosState (..)- , Parsec- , ParsecT+ State (..),+ PosState (..),+ Parsec,+ ParsecT,+ -- * Running parser- , parse- , parseMaybe- , parseTest- , runParser- , runParser'- , runParserT- , runParserT'+ parse,+ parseMaybe,+ parseTest,+ runParser,+ runParser',+ runParserT,+ runParserT',+ -- * Primitive combinators- , MonadParsec (..)+ MonadParsec (..),+ -- * Signaling parse errors -- $parse-errors- , failure- , fancyFailure- , unexpected- , customFailure- , region- , registerParseError- , registerFailure- , registerFancyFailure+ failure,+ fancyFailure,+ unexpected,+ customFailure,+ region,+ registerParseError,+ registerFailure,+ registerFancyFailure,+ -- * Derivatives of primitive combinators- , single- , satisfy- , anySingle- , anySingleBut- , oneOf- , noneOf- , chunk- , (<?>)- , match- , takeRest- , atEnd+ single,+ satisfy,+ anySingle,+ anySingleBut,+ oneOf,+ noneOf,+ chunk,+ (<?>),+ match,+ takeRest,+ atEnd,+ -- * Parser state combinators- , getInput- , setInput- , getSourcePos- , getOffset- , setOffset- , setParserState )+ getInput,+ setInput,+ getSourcePos,+ getOffset,+ setOffset,+ setParserState,+ ) where import Control.Monad.Combinators import Control.Monad.Identity import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust) import Data.Set (Set)+import qualified Data.Set as E import Text.Megaparsec.Class import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E -- $reexports --@@ -150,7 +155,6 @@ -- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' -- monad transformer.- type Parsec e s = ParsecT e s Identity ----------------------------------------------------------------------------@@ -169,12 +173,14 @@ -- > Right xs -> print (sum xs) -- > -- > numbers = decimal `sepBy` char ','--parse- :: Parsec e s a -- ^ Parser to run- -> String -- ^ Name of source file- -> s -- ^ Input for parser- -> Either (ParseErrorBundle s e) a+parse ::+ -- | Parser to run+ Parsec e s a ->+ -- | Name of source file+ String ->+ -- | Input for parser+ s ->+ Either (ParseErrorBundle s e) a parse = runParser -- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the@@ -186,26 +192,28 @@ -- error messages (and thus file names) are not important and entire input -- should be parsed. For example, it can be used when parsing of a single -- number according to a specification of its format is desired.- parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s = case parse (p <* eof) "" s of- Left _ -> Nothing+ Left _ -> Nothing Right x -> Just x -- | The expression @'parseTest' p input@ applies the parser @p@ against the -- input @input@ and prints the result to stdout. Useful for testing.--parseTest :: ( ShowErrorComponent e- , Show a- , Stream s- )- => Parsec e s a -- ^ Parser to run- -> s -- ^ Input for parser- -> IO ()+parseTest ::+ ( ShowErrorComponent e,+ Show a,+ VisualStream s,+ TraversableStream s+ ) =>+ -- | Parser to run+ Parsec e s a ->+ -- | Input for parser+ s ->+ IO () parseTest p input = case parse p "" input of- Left e -> putStr (errorBundlePretty e)+ Left e -> putStr (errorBundlePretty e) Right x -> print x -- | @'runParser' p file input@ runs parser @p@ on the input stream of@@ -214,12 +222,14 @@ -- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file--runParser- :: Parsec e s a -- ^ Parser to run- -> String -- ^ Name of source file- -> s -- ^ Input for parser- -> Either (ParseErrorBundle s e) a+runParser ::+ -- | Parser to run+ Parsec e s a ->+ -- | Name of source file+ String ->+ -- | Input for parser+ s ->+ Either (ParseErrorBundle s e) a runParser p name s = snd $ runParser' p (initialState name s) -- | The function is similar to 'runParser' with the difference that it@@ -228,11 +238,12 @@ -- most general way to run a parser over the 'Identity' monad. -- -- @since 4.2.0--runParser'- :: Parsec e s a -- ^ Parser to run- -> State s e -- ^ Initial state- -> (State s e, Either (ParseErrorBundle s e) a)+runParser' ::+ -- | Parser to run+ Parsec e s a ->+ -- | Initial state+ State s e ->+ (State s e, Either (ParseErrorBundle s e) a) runParser' p = runIdentity . runParserT' p -- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens@@ -240,12 +251,15 @@ -- messages and may be the empty string. Returns a computation in the -- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or -- a value of type @a@ ('Right').--runParserT :: Monad m- => ParsecT e s m a -- ^ Parser to run- -> String -- ^ Name of source file- -> s -- ^ Input for parser- -> m (Either (ParseErrorBundle s e) a)+runParserT ::+ Monad m =>+ -- | Parser to run+ ParsecT e s m a ->+ -- | Name of source file+ String ->+ -- | Input for parser+ s ->+ m (Either (ParseErrorBundle s e) a) runParserT p name s = snd <$> runParserT' p (initialState name s) -- | This function is similar to 'runParserT', but like 'runParser'' it@@ -253,18 +267,21 @@ -- run a parser. -- -- @since 4.2.0--runParserT' :: Monad m- => ParsecT e s m a -- ^ Parser to run- -> State s e -- ^ Initial state- -> m (State s e, Either (ParseErrorBundle s e) a)+runParserT' ::+ Monad m =>+ -- | Parser to run+ ParsecT e s m a ->+ -- | Initial state+ State s e ->+ m (State s e, Either (ParseErrorBundle s e) a) runParserT' p s = do (Reply s' _ result) <- runParsecT p s- let toBundle es = ParseErrorBundle- { bundleErrors =- NE.sortWith errorOffset es- , bundlePosState = statePosState s- }+ let toBundle es =+ ParseErrorBundle+ { bundleErrors =+ NE.sortWith errorOffset es,+ bundlePosState = statePosState s+ } return $ case result of OK x -> case NE.nonEmpty (stateParseErrors s') of@@ -274,20 +291,21 @@ (s', Left (toBundle (e :| stateParseErrors s'))) -- | Given name of source file and input construct initial state for parser.- initialState :: String -> s -> State s e-initialState name s = State- { stateInput = s- , stateOffset = 0- , statePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos name- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""+initialState name s =+ State+ { stateInput = s,+ stateOffset = 0,+ statePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos name,+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ },+ stateParseErrors = [] }- , stateParseErrors = []- } ---------------------------------------------------------------------------- -- Signaling parse errors@@ -302,12 +320,13 @@ -- | Stop parsing and report a trivial 'ParseError'. -- -- @since 6.0.0--failure- :: MonadParsec e s m- => Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any)- -> Set (ErrorItem (Token s)) -- ^ Expected items- -> m a+failure ::+ MonadParsec e s m =>+ -- | Unexpected item (if any)+ Maybe (ErrorItem (Token s)) ->+ -- | Expected items+ Set (ErrorItem (Token s)) ->+ m a failure us ps = do o <- getOffset parseError (TrivialError o us ps)@@ -317,11 +336,11 @@ -- parse error, see 'Text.Megaparsec.customFailure'. -- -- @since 6.0.0--fancyFailure- :: MonadParsec e s m- => Set (ErrorFancy e) -- ^ Fancy error components- -> m a+fancyFailure ::+ MonadParsec e s m =>+ -- | Fancy error components+ Set (ErrorFancy e) ->+ m a fancyFailure xs = do o <- getOffset parseError (FancyError o xs)@@ -331,7 +350,6 @@ -- about unexpected item @item@ without consuming any input. -- -- > unexpected item = failure (Just item) Set.empty- unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-}@@ -342,7 +360,6 @@ -- > customFailure = fancyFailure . Set.singleton . ErrorCustom -- -- @since 6.3.0- customFailure :: MonadParsec e s m => e -> m a customFailure = fancyFailure . E.singleton . ErrorCustom {-# INLINE customFailure #-}@@ -355,19 +372,20 @@ -- “restored” on the way out of 'region'. -- -- @since 5.3.0--region :: MonadParsec e s m- => (ParseError s e -> ParseError s e)- -- ^ How to process 'ParseError's- -> m a -- ^ The “region” that the processing applies to- -> m a+region ::+ MonadParsec e s m =>+ -- | How to process 'ParseError's+ (ParseError s e -> ParseError s e) ->+ -- | The “region” that the processing applies to+ m a ->+ m a region f m = do deSoFar <- stateParseErrors <$> getParserState updateParserState $ \s ->- s { stateParseErrors = [] }+ s {stateParseErrors = []} r <- observing m updateParserState $ \s ->- s { stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar }+ s {stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar} case r of Left err -> parseError (f err) Right x -> return x@@ -381,21 +399,21 @@ -- at once. -- -- @since 8.0.0- registerParseError :: MonadParsec e s m => ParseError s e -> m () registerParseError e = updateParserState $ \s ->- s { stateParseErrors = e : stateParseErrors s }+ s {stateParseErrors = e : stateParseErrors s} {-# INLINE registerParseError #-} -- | Like 'failure', but for delayed 'ParseError's. -- -- @since 8.0.0--registerFailure- :: MonadParsec e s m- => Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any)- -> Set (ErrorItem (Token s)) -- ^ Expected items- -> m ()+registerFailure ::+ MonadParsec e s m =>+ -- | Unexpected item (if any)+ Maybe (ErrorItem (Token s)) ->+ -- | Expected items+ Set (ErrorItem (Token s)) ->+ m () registerFailure us ps = do o <- getOffset registerParseError (TrivialError o us ps)@@ -404,11 +422,11 @@ -- | Like 'fancyFailure', but for delayed 'ParseError's. -- -- @since 8.0.0--registerFancyFailure- :: MonadParsec e s m- => Set (ErrorFancy e) -- ^ Fancy error components- -> m ()+registerFancyFailure ::+ MonadParsec e s m =>+ -- | Fancy error components+ Set (ErrorFancy e) ->+ m () registerFancyFailure xs = do o <- getOffset registerParseError (FancyError o xs)@@ -425,14 +443,15 @@ -- 'Text.Megaparsec.Char.char'. -- -- @since 7.0.0--single :: MonadParsec e s m- => Token s -- ^ Token to match- -> m (Token s)+single ::+ MonadParsec e s m =>+ -- | Token to match+ Token s ->+ m (Token s) single t = token testToken expected where testToken x = if x == t then Just x else Nothing- expected = E.singleton (Tokens (t:|[]))+ expected = E.singleton (Tokens (t :| [])) {-# INLINE single #-} -- | The parser @'satisfy' f@ succeeds for any token for which the supplied@@ -444,10 +463,11 @@ -- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'. -- -- @since 7.0.0--satisfy :: MonadParsec e s m- => (Token s -> Bool) -- ^ Predicate to apply- -> m (Token s)+satisfy ::+ MonadParsec e s m =>+ -- | Predicate to apply+ (Token s -> Bool) ->+ m (Token s) satisfy f = token testChar E.empty where testChar x = if f x then Just x else Nothing@@ -461,7 +481,6 @@ -- See also: 'satisfy', 'anySingleBut'. -- -- @since 7.0.0- anySingle :: MonadParsec e s m => m (Token s) anySingle = satisfy (const True) {-# INLINE anySingle #-}@@ -474,10 +493,11 @@ -- See also: 'single', 'anySingle', 'satisfy'. -- -- @since 7.0.0--anySingleBut :: MonadParsec e s m- => Token s -- ^ Token we should not match- -> m (Token s)+anySingleBut ::+ MonadParsec e s m =>+ -- | Token we should not match+ Token s ->+ m (Token s) anySingleBut t = satisfy (/= t) {-# INLINE anySingleBut #-} @@ -499,10 +519,11 @@ -- > quoteSlow = oneOf "'\"" -- -- @since 7.0.0--oneOf :: (Foldable f, MonadParsec e s m)- => f (Token s) -- ^ Collection of matching tokens- -> m (Token s)+oneOf ::+ (Foldable f, MonadParsec e s m) =>+ -- | Collection of matching tokens+ f (Token s) ->+ m (Token s) oneOf cs = satisfy (`elem` cs) {-# INLINE oneOf #-} @@ -520,10 +541,11 @@ -- because it's faster. -- -- @since 7.0.0--noneOf :: (Foldable f, MonadParsec e s m)- => f (Token s) -- ^ Collection of taken we should not match- -> m (Token s)+noneOf ::+ (Foldable f, MonadParsec e s m) =>+ -- | Collection of taken we should not match+ f (Token s) ->+ m (Token s) noneOf cs = satisfy (`notElem` cs) {-# INLINE noneOf #-} @@ -535,15 +557,15 @@ -- 'Text.Megaparsec.Byte.string'. -- -- @since 7.0.0--chunk :: MonadParsec e s m- => Tokens s -- ^ Chunk to match- -> m (Tokens s)+chunk ::+ MonadParsec e s m =>+ -- | Chunk to match+ Tokens s ->+ m (Tokens s) chunk = tokens (==) {-# INLINE chunk #-} -- | A synonym for 'label' in the form of an operator.- infix 0 <?> (<?>) :: MonadParsec e s m => m a -> String -> m a@@ -556,12 +578,11 @@ -- manually in the argument parser, prepare for troubles. -- -- @since 5.3.0- match :: MonadParsec e s m => m a -> m (Tokens s, a) match p = do- o <- getOffset- s <- getInput- r <- p+ o <- getOffset+ s <- getInput+ r <- p o' <- getOffset -- NOTE The 'fromJust' call here should never fail because if the stream -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing'@@ -577,7 +598,6 @@ -- > takeRest = takeWhileP Nothing (const True) -- -- @since 6.0.0- takeRest :: MonadParsec e s m => m (Tokens s) takeRest = takeWhileP Nothing (const True) {-# INLINE takeRest #-}@@ -587,7 +607,6 @@ -- > atEnd = option False (True <$ hidden eof) -- -- @since 6.0.0- atEnd :: MonadParsec e s m => m Bool atEnd = option False (True <$ hidden eof) {-# INLINE atEnd #-}@@ -596,13 +615,11 @@ -- Parser state combinators -- | Return the current input.- getInput :: MonadParsec e s m => m s getInput = stateInput <$> getParserState {-# INLINE getInput #-} -- | @'setInput' input@ continues parsing with @input@.- setInput :: MonadParsec e s m => s -> m () setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) {-# INLINE setInput #-}@@ -616,12 +633,11 @@ -- abuses the library. -- -- @since 7.0.0--getSourcePos :: MonadParsec e s m => m SourcePos+getSourcePos :: (TraversableStream s, MonadParsec e s m) => m SourcePos getSourcePos = do st <- getParserState let pst = reachOffsetNoLine (stateOffset st) (statePosState st)- setParserState st { statePosState = pst }+ setParserState st {statePosState = pst} return (pstateSourcePos pst) {-# INLINE getSourcePos #-} @@ -630,7 +646,6 @@ -- See also: 'setOffset'. -- -- @since 7.0.0- getOffset :: MonadParsec e s m => m Int getOffset = stateOffset <$> getParserState {-# INLINE getOffset #-}@@ -640,7 +655,6 @@ -- See also: 'getOffset'. -- -- @since 7.0.0- setOffset :: MonadParsec e s m => Int -> m () setOffset o = updateParserState $ \(State s _ pst de) -> State s o pst de@@ -649,7 +663,6 @@ -- | @'setParserState' st@ sets the parser state to @st@. -- -- See also: 'getParserState', 'updateParserState'.- setParserState :: MonadParsec e s m => State s e -> m () setParserState st = updateParserState (const st) {-# INLINE setParserState #-}
Text/Megaparsec/Byte.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Text.Megaparsec.Byte -- Copyright : © 2015–present Megaparsec contributors@@ -10,41 +13,43 @@ -- Commonly used binary parsers. -- -- @since 6.0.0--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}- module Text.Megaparsec.Byte ( -- * Simple parsers- newline- , crlf- , eol- , tab- , space- , space1+ newline,+ crlf,+ eol,+ tab,+ space,+ hspace,+ space1,+ hspace1,+ -- * Categories of characters- , controlChar- , spaceChar- , upperChar- , lowerChar- , letterChar- , alphaNumChar- , printChar- , digitChar- , binDigitChar- , octDigitChar- , hexDigitChar- , asciiChar+ controlChar,+ spaceChar,+ upperChar,+ lowerChar,+ letterChar,+ alphaNumChar,+ printChar,+ digitChar,+ binDigitChar,+ octDigitChar,+ hexDigitChar,+ asciiChar,+ -- * Single byte- , char- , char'+ char,+ char',+ -- * Sequence of bytes- , string- , string' )+ string,+ string',+ ) where import Control.Applicative-import Data.Char hiding (toLower, toUpper)+import Data.Char hiding (isSpace, toLower, toUpper) import Data.Functor (void) import Data.Proxy import Data.Word (Word8)@@ -55,29 +60,26 @@ -- Simple parsers -- | Parse a newline byte.- newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) newline = char 10 {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed.- crlf :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s)-crlf = string (tokensToChunk (Proxy :: Proxy s) [13,10])+crlf = string (tokensToChunk (Proxy :: Proxy s) [13, 10]) {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed.- eol :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s)-eol = (tokenToChunk (Proxy :: Proxy s) <$> newline)- <|> crlf- <?> "end of line"+eol =+ (tokenToChunk (Proxy :: Proxy s) <$> newline)+ <|> crlf+ <?> "end of line" {-# INLINE eol #-} -- | Parse a tab character.- tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) tab = char 9 {-# INLINE tab #-}@@ -85,68 +87,72 @@ -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'.- space :: (MonadParsec e s m, Token s ~ Word8) => m ()-space = void $ takeWhileP (Just "white space") isSpace'+space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns.+--+-- @since 9.0.0+hspace :: (MonadParsec e s m, Token s ~ Word8) => m ()+hspace = void $ takeWhileP (Just "white space") isHSpace+{-# INLINE hspace #-}+ -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'.- space1 :: (MonadParsec e s m, Token s ~ Word8) => m ()-space1 = void $ takeWhile1P (Just "white space") isSpace'+space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns.+--+-- @since 9.0.0+hspace1 :: (MonadParsec e s m, Token s ~ Word8) => m ()+hspace1 = void $ takeWhile1P (Just "white space") isHSpace+{-# INLINE hspace1 #-}+ ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character.- controlChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) controlChar = satisfy (isControl . toChar) <?> "control character" {-# INLINE controlChar #-} -- | Parse a space character, and the control characters: tab, newline, -- carriage return, form feed, and vertical tab.- spaceChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-spaceChar = satisfy isSpace' <?> "white space"+spaceChar = satisfy isSpace <?> "white space" {-# INLINE spaceChar #-} -- | Parse an upper-case character.- upperChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) upperChar = satisfy (isUpper . toChar) <?> "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic character.- lowerChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) lowerChar = satisfy (isLower . toChar) <?> "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic character: lower-case or upper-case.- letterChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) letterChar = satisfy (isLetter . toChar) <?> "letter" {-# INLINE letterChar #-} -- | Parse an alphabetic or digit characters.- alphaNumChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) alphaNumChar = satisfy (isAlphaNum . toChar) <?> "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable character: letter, number, mark, punctuation, symbol -- or space.- printChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) printChar = satisfy (isPrint . toChar) <?> "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”.- digitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) digitChar = satisfy isDigit' <?> "digit" where@@ -156,7 +162,6 @@ -- | Parse a binary digit, i.e. “0” or “1”. -- -- @since 7.0.0- binDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) binDigitChar = satisfy isBinDigit <?> "binary digit" where@@ -164,7 +169,6 @@ {-# INLINE binDigitChar #-} -- | Parse an octal digit, i.e. between “0” and “7”.- octDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) octDigitChar = satisfy isOctDigit' <?> "octal digit" where@@ -173,14 +177,12 @@ -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”.- hexDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) hexDigitChar = satisfy (isHexDigit . toChar) <?> "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set.- asciiChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) asciiChar = satisfy (< 128) <?> "ASCII character" {-# INLINE asciiChar #-}@@ -191,7 +193,6 @@ -- | A type-constrained version of 'single'. -- -- > newline = char 10- char :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) char = single {-# INLINE char #-}@@ -205,35 +206,43 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e'- char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s)-char' c = choice- [ char (toLower c)- , char (toUpper c)- ]+char' c =+ choice+ [ char (toLower c),+ char (toUpper c)+ ] {-# INLINE char' #-} ---------------------------------------------------------------------------- -- Helpers --- | 'Word8'-specialized version of 'isSpace'.--isSpace' :: Word8 -> Bool-isSpace' x+-- | 'Word8'-specialized version of 'Data.Char.isSpace'.+isSpace :: Word8 -> Bool+isSpace x | x >= 9 && x <= 13 = True- | x == 32 = True- | x == 160 = True- | otherwise = False-{-# INLINE isSpace' #-}+ | x == 32 = True+ | x == 160 = True+ | otherwise = False+{-# INLINE isSpace #-} --- | Convert a byte to char.+-- | Like 'isSpace', but does not accept newlines and carriage returns.+isHSpace :: Word8 -> Bool+isHSpace x+ | x == 9 = True+ | x == 11 = True+ | x == 12 = True+ | x == 32 = True+ | x == 160 = True+ | otherwise = False+{-# INLINE isHSpace #-} +-- | Convert a byte to char. toChar :: Word8 -> Char toChar = chr . fromIntegral {-# INLINE toChar #-} -- | Convert a byte to its upper-case version.- toUpper :: Word8 -> Word8 toUpper x | x >= 97 && x <= 122 = x - 32@@ -244,7 +253,6 @@ {-# INLINE toUpper #-} -- | Convert a byte to its lower-case version.- toLower :: Word8 -> Word8 toLower x | x >= 65 && x <= 90 = x + 32
Text/Megaparsec/Byte/Lexer.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Text.Megaparsec.Byte.Lexer -- Copyright : © 2015–present Megaparsec contributors@@ -13,27 +16,25 @@ -- This module is intended to be imported qualified: -- -- > import qualified Text.Megaparsec.Byte.Lexer as L--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}- module Text.Megaparsec.Byte.Lexer ( -- * White space- space- , lexeme- , symbol- , symbol'- , skipLineComment- , skipBlockComment- , skipBlockCommentNested+ space,+ lexeme,+ symbol,+ symbol',+ skipLineComment,+ skipBlockComment,+ skipBlockCommentNested,+ -- * Numbers- , decimal- , binary- , octal- , hexadecimal- , scientific- , float- , signed )+ decimal,+ binary,+ octal,+ hexadecimal,+ scientific,+ float,+ signed,+ ) where import Control.Applicative@@ -41,11 +42,11 @@ import Data.List (foldl') import Data.Proxy import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci import Data.Word (Word8) import Text.Megaparsec-import Text.Megaparsec.Lexer-import qualified Data.Scientific as Sci import qualified Text.Megaparsec.Byte as B+import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space@@ -54,21 +55,24 @@ -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually.--skipLineComment :: (MonadParsec e s m, Token s ~ Word8)- => Tokens s -- ^ Line comment prefix- -> m ()+skipLineComment ::+ (MonadParsec e s m, Token s ~ Word8) =>+ -- | Line comment prefix+ Tokens s ->+ m () skipLineComment prefix = B.string prefix *> void (takeWhileP (Just "character") (/= 10)) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@.--skipBlockComment :: (MonadParsec e s m, Token s ~ Word8)- => Tokens s -- ^ Start of block comment- -> Tokens s -- ^ End of block comment- -> m ()+skipBlockComment ::+ (MonadParsec e s m, Token s ~ Word8) =>+ -- | Start of block comment+ Tokens s ->+ -- | End of block comment+ Tokens s ->+ m () skipBlockComment start end = p >> void (manyTill anySingle n) where p = B.string start@@ -79,11 +83,13 @@ -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0--skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Word8)- => Tokens s -- ^ Start of block comment- -> Tokens s -- ^ End of block comment- -> m ()+skipBlockCommentNested ::+ (MonadParsec e s m, Token s ~ Word8) =>+ -- | Start of block comment+ Tokens s ->+ -- | End of block comment+ Tokens s ->+ m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void anySingle@@ -98,21 +104,21 @@ -- integer literals described in the Haskell report. -- -- If you need to parse signed integers, see the 'signed' combinator.--decimal- :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a)- => m a+decimal ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ m a decimal = decimal_ <?> "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers.--decimal_- :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a)- => m a+decimal_ ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ m a decimal_ = mkNum <$> takeWhile1P (Just "digit") isDigit where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w = a * 10 + fromIntegral (w - 48) {-# INLINE decimal_ #-} @@ -124,16 +130,17 @@ -- > binary = char 48 >> char' 98 >> L.binary -- -- @since 7.0.0--binary- :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a)- => m a-binary = mkNum- <$> takeWhile1P Nothing isBinDigit- <?> "binary integer"+binary ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ m a+binary =+ mkNum+ <$> takeWhile1P Nothing isBinDigit+ <?> "binary integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)- step a w = a * 2 + fromIntegral (w - 48)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a w = a * 2 + fromIntegral (w - 48) isBinDigit w = w == 48 || w == 49 {-# INLINEABLE binary #-} @@ -146,16 +153,17 @@ -- For example you can make it conform to the Haskell report like this: -- -- > octal = char 48 >> char' 111 >> L.octal--octal- :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a)- => m a-octal = mkNum- <$> takeWhile1P Nothing isOctDigit- <?> "octal integer"+octal ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ m a+octal =+ mkNum+ <$> takeWhile1P Nothing isOctDigit+ <?> "octal integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)- step a w = a * 8 + fromIntegral (w - 48)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a w = a * 8 + fromIntegral (w - 48) isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-} @@ -168,23 +176,24 @@ -- For example you can make it conform to the Haskell report like this: -- -- > hexadecimal = char 48 >> char' 120 >> L.hexadecimal--hexadecimal- :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a)- => m a-hexadecimal = mkNum- <$> takeWhile1P Nothing isHexDigit- <?> "hexadecimal integer"+hexadecimal ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ m a+hexadecimal =+ mkNum+ <$> takeWhile1P Nothing isHexDigit+ <?> "hexadecimal integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48)- | w >= 97 = a * 16 + fromIntegral (w - 87)- | otherwise = a * 16 + fromIntegral (w - 55)+ | w >= 97 = a * 16 + fromIntegral (w - 87)+ | otherwise = a * 16 + fromIntegral (w - 55) isHexDigit w =- (w >= 48 && w <= 57) ||- (w >= 97 && w <= 102) ||- (w >= 65 && w <= 70)+ (w >= 48 && w <= 57)+ || (w >= 97 && w <= 102)+ || (w >= 65 && w <= 70) {-# INLINEABLE hexadecimal #-} -- | Parse a floating point value as a 'Scientific' number. 'Scientific' is@@ -197,14 +206,14 @@ -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'.--scientific- :: forall e s m. (MonadParsec e s m, Token s ~ Word8)- => m Scientific+scientific ::+ forall e s m.+ (MonadParsec e s m, Token s ~ Word8) =>+ m Scientific scientific = do- c' <- decimal_+ c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c')- e <- option e' (try $ exponent_ e')+ e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -216,34 +225,39 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. ----- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers.-+-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain integers. float :: (MonadParsec e s m, Token s ~ Word8, RealFloat a) => m a float = do c' <- decimal_- Sci.toRealFloat <$>- ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c'- e <- option e' (try $ exponent_ e')- return (Sci.scientific c e))- <|> (Sci.scientific c' <$> exponent_ 0))+ Sci.toRealFloat+ <$> ( ( do+ SP c e' <- dotDecimal_ (Proxy :: Proxy s) c'+ e <- option e' (try $ exponent_ e')+ return (Sci.scientific c e)+ )+ <|> (Sci.scientific c' <$> exponent_ 0)+ ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Word8)- => Proxy s- -> Integer- -> m SP+dotDecimal_ ::+ (MonadParsec e s m, Token s ~ Word8) =>+ Proxy s ->+ Integer ->+ m SP dotDecimal_ pxy c' = do void (B.char 46)- let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy- step (SP a e') w = SP- (a * 10 + fromIntegral (w - 48))- (e' - 1)+ let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+ step (SP a e') w =+ SP+ (a * 10 + fromIntegral (w - 48))+ (e' - 1) mkNum <$> takeWhile1P (Just "digit") isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Word8)- => Int- -> m Int+exponent_ ::+ (MonadParsec e s m, Token s ~ Word8) =>+ Int ->+ m Int exponent_ e' = do void (B.char' 101) (+ e') <$> signed (return ()) decimal_@@ -260,11 +274,14 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer--signed :: (MonadParsec e s m, Token s ~ Word8, Num a)- => m () -- ^ How to consume white space after the sign- -> m a -- ^ How to parse the number itself- -> m a -- ^ Parser for signed numbers+signed ::+ (MonadParsec e s m, Token s ~ Word8, Num a) =>+ -- | How to consume white space after the sign+ m () ->+ -- | How to parse the number itself+ m a ->+ -- | Parser for signed numbers+ m a signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ B.char 43) <|> (negate <$ B.char 45)@@ -274,7 +291,6 @@ -- Helpers -- | A fast predicate to check if given 'Word8' is a digit in ASCII.- isDigit :: Word8 -> Bool isDigit w = w - 48 < 10 {-# INLINE isDigit #-}
Text/Megaparsec/Char.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Text.Megaparsec.Char -- Copyright : © 2015–present Megaparsec contributors@@ -10,47 +15,47 @@ -- Portability : non-portable -- -- Commonly used character parsers.--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}- module Text.Megaparsec.Char ( -- * Simple parsers- newline- , crlf- , eol- , tab- , space- , space1+ newline,+ crlf,+ eol,+ tab,+ space,+ hspace,+ space1,+ hspace1,+ -- * Categories of characters- , controlChar- , spaceChar- , upperChar- , lowerChar- , letterChar- , alphaNumChar- , printChar- , digitChar- , binDigitChar- , octDigitChar- , hexDigitChar- , markChar- , numberChar- , punctuationChar- , symbolChar- , separatorChar- , asciiChar- , latin1Char- , charCategory- , categoryName+ controlChar,+ spaceChar,+ upperChar,+ lowerChar,+ letterChar,+ alphaNumChar,+ printChar,+ digitChar,+ binDigitChar,+ octDigitChar,+ hexDigitChar,+ markChar,+ numberChar,+ punctuationChar,+ symbolChar,+ separatorChar,+ asciiChar,+ latin1Char,+ charCategory,+ categoryName,+ -- * Single character- , char- , char'+ char,+ char',+ -- * Sequence of characters- , string- , string' )+ string,+ string',+ ) where import Control.Applicative@@ -64,29 +69,26 @@ -- Simple parsers -- | Parse a newline character.- newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed.- crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed.- eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s)-eol = (tokenToChunk (Proxy :: Proxy s) <$> newline)- <|> crlf- <?> "end of line"+eol =+ (tokenToChunk (Proxy :: Proxy s) <$> newline)+ <|> crlf+ <?> "end of line" {-# INLINE eol #-} -- | Parse a tab character.- tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-}@@ -94,34 +96,44 @@ -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'.- space :: (MonadParsec e s m, Token s ~ Char) => m () space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns.+--+-- @since 9.0.0+hspace :: (MonadParsec e s m, Token s ~ Char) => m ()+hspace = void $ takeWhileP (Just "white space") isHSpace+{-# INLINE hspace #-}+ -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'. -- -- @since 6.0.0- space1 :: (MonadParsec e s m, Token s ~ Char) => m () space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns.+--+-- @since 8.0.0+hspace1 :: (MonadParsec e s m, Token s ~ Char) => m ()+hspace1 = void $ takeWhile1P (Just "white space") isHSpace+{-# INLINE hspace1 #-}+ ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode).- controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl <?> "control character" {-# INLINE controlChar #-} -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab.- spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace <?> "white space" {-# INLINE spaceChar #-}@@ -129,20 +141,17 @@ -- | Parse an upper-case or title-case alphabetic Unicode character. Title -- case is used by a small number of letter ligatures like the -- single-character form of Lj.- upperChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) upperChar = satisfy isUpper <?> "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic Unicode character.- lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower <?> "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter.- letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter <?> "letter" {-# INLINE letterChar #-}@@ -152,20 +161,17 @@ -- Note that the numeric digits outside the ASCII range are parsed by this -- parser but not by 'digitChar'. Such digits may be part of identifiers but -- are not used by the printer and reader to represent numbers.- alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) alphaNumChar = satisfy isAlphaNum <?> "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space.- printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint <?> "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”.- digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit <?> "digit" {-# INLINE digitChar #-}@@ -173,7 +179,6 @@ -- | Parse a binary digit, i.e. "0" or "1". -- -- @since 7.0.0- binDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) binDigitChar = satisfy isBinDigit <?> "binary digit" where@@ -181,109 +186,99 @@ {-# INLINE binDigitChar #-} -- | Parse an octal digit, i.e. between “0” and “7”.- octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) octDigitChar = satisfy isOctDigit <?> "octal digit" {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”.- hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit <?> "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters.- markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark <?> "mark character" {-# INLINE markChar #-} -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc.- numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber <?> "numeric character" {-# INLINE numberChar #-} -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes.- punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) punctuationChar = satisfy isPunctuation <?> "punctuation" {-# INLINE punctuationChar #-} -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols.- symbolChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) symbolChar = satisfy isSymbol <?> "symbol" {-# INLINE symbolChar #-} -- | Parse a Unicode space and separator characters.- separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator <?> "separator" {-# INLINE separatorChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set.- asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii <?> "ASCII character" {-# INLINE asciiChar #-} -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set.- latin1Char :: (MonadParsec e s m, Token s ~ Char) => m (Token s) latin1Char = satisfy isLatin1 <?> "Latin-1 character" {-# INLINE latin1Char #-} -- | @'charCategory' cat@ parses character in Unicode General Category -- @cat@, see 'Data.Char.GeneralCategory'.--charCategory :: (MonadParsec e s m, Token s ~ Char)- => GeneralCategory- -> m (Token s)+charCategory ::+ (MonadParsec e s m, Token s ~ Char) =>+ GeneralCategory ->+ m (Token s) charCategory cat = satisfy ((== cat) . generalCategory) <?> categoryName cat {-# INLINE charCategory #-} -- | Return the human-readable name of Unicode General Category.- categoryName :: GeneralCategory -> String categoryName = \case- UppercaseLetter -> "uppercase letter"- LowercaseLetter -> "lowercase letter"- TitlecaseLetter -> "titlecase letter"- ModifierLetter -> "modifier letter"- OtherLetter -> "other letter"- NonSpacingMark -> "non-spacing mark"+ UppercaseLetter -> "uppercase letter"+ LowercaseLetter -> "lowercase letter"+ TitlecaseLetter -> "titlecase letter"+ ModifierLetter -> "modifier letter"+ OtherLetter -> "other letter"+ NonSpacingMark -> "non-spacing mark" SpacingCombiningMark -> "spacing combining mark"- EnclosingMark -> "enclosing mark"- DecimalNumber -> "decimal number character"- LetterNumber -> "letter number character"- OtherNumber -> "other number character"+ EnclosingMark -> "enclosing mark"+ DecimalNumber -> "decimal number character"+ LetterNumber -> "letter number character"+ OtherNumber -> "other number character" ConnectorPunctuation -> "connector punctuation"- DashPunctuation -> "dash punctuation"- OpenPunctuation -> "open punctuation"- ClosePunctuation -> "close punctuation"- InitialQuote -> "initial quote"- FinalQuote -> "final quote"- OtherPunctuation -> "other punctuation"- MathSymbol -> "math symbol"- CurrencySymbol -> "currency symbol"- ModifierSymbol -> "modifier symbol"- OtherSymbol -> "other symbol"- Space -> "white space"- LineSeparator -> "line separator"- ParagraphSeparator -> "paragraph separator"- Control -> "control character"- Format -> "format character"- Surrogate -> "surrogate character"- PrivateUse -> "private-use Unicode character"- NotAssigned -> "non-assigned Unicode character"+ DashPunctuation -> "dash punctuation"+ OpenPunctuation -> "open punctuation"+ ClosePunctuation -> "close punctuation"+ InitialQuote -> "initial quote"+ FinalQuote -> "final quote"+ OtherPunctuation -> "other punctuation"+ MathSymbol -> "math symbol"+ CurrencySymbol -> "currency symbol"+ ModifierSymbol -> "modifier symbol"+ OtherSymbol -> "other symbol"+ Space -> "white space"+ LineSeparator -> "line separator"+ ParagraphSeparator -> "paragraph separator"+ Control -> "control character"+ Format -> "format character"+ Surrogate -> "surrogate character"+ PrivateUse -> "private-use Unicode character"+ NotAssigned -> "non-assigned Unicode character" ---------------------------------------------------------------------------- -- Single character@@ -291,7 +286,6 @@ -- | A type-constrained version of 'single'. -- -- > semicolon = char ';'- char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char = single {-# INLINE char #-}@@ -305,11 +299,18 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e'- char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s)-char' c = choice- [ char (toLower c)- , char (toUpper c)- , char (toTitle c)- ]+char' c =+ choice+ [ char (toLower c),+ char (toUpper c),+ char (toTitle c)+ ] {-# INLINE char' #-}++----------------------------------------------------------------------------+-- Helpers++-- | Is it a horizontal space character?+isHSpace :: Char -> Bool+isHSpace x = isSpace x && x /= '\n' && x /= '\r'
Text/Megaparsec/Char/Lexer.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Text.Megaparsec.Char.Lexer -- Copyright : © 2015–present Megaparsec contributors@@ -26,54 +31,52 @@ -- > import qualified Text.Megaparsec.Char.Lexer as L -- -- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer".--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}- module Text.Megaparsec.Char.Lexer ( -- * White space- space- , lexeme- , symbol- , symbol'- , skipLineComment- , skipBlockComment- , skipBlockCommentNested+ space,+ lexeme,+ symbol,+ symbol',+ skipLineComment,+ skipBlockComment,+ skipBlockCommentNested,+ -- * Indentation- , indentLevel- , incorrectIndent- , indentGuard- , nonIndented- , IndentOpt (..)- , indentBlock- , lineFold+ indentLevel,+ incorrectIndent,+ indentGuard,+ nonIndented,+ IndentOpt (..),+ indentBlock,+ lineFold,+ -- * Character and string literals- , charLiteral+ charLiteral,+ -- * Numbers- , decimal- , binary- , octal- , hexadecimal- , scientific- , float- , signed )+ decimal,+ binary,+ octal,+ hexadecimal,+ scientific,+ float,+ signed,+ ) where import Control.Applicative import Control.Monad (void)+import qualified Data.Char as Char import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (listToMaybe, fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import qualified Data.Set as E import Text.Megaparsec-import Text.Megaparsec.Lexer-import qualified Data.Char as Char-import qualified Data.Scientific as Sci-import qualified Data.Set as E import qualified Text.Megaparsec.Char as C+import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space@@ -82,21 +85,24 @@ -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually.--skipLineComment :: (MonadParsec e s m, Token s ~ Char)- => Tokens s -- ^ Line comment prefix- -> m ()+skipLineComment ::+ (MonadParsec e s m, Token s ~ Char) =>+ -- | Line comment prefix+ Tokens s ->+ m () skipLineComment prefix = C.string prefix *> void (takeWhileP (Just "character") (/= '\n')) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@.--skipBlockComment :: (MonadParsec e s m, Token s ~ Char)- => Tokens s -- ^ Start of block comment- -> Tokens s -- ^ End of block comment- -> m ()+skipBlockComment ::+ (MonadParsec e s m, Token s ~ Char) =>+ -- | Start of block comment+ Tokens s ->+ -- | End of block comment+ Tokens s ->+ m () skipBlockComment start end = p >> void (manyTill anySingle n) where p = C.string start@@ -107,11 +113,13 @@ -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0--skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char)- => Tokens s -- ^ Start of block comment- -> Tokens s -- ^ End of block comment- -> m ()+skipBlockCommentNested ::+ (MonadParsec e s m, Token s ~ Char) =>+ -- | Start of block comment+ Tokens s ->+ -- | End of block comment+ Tokens s ->+ m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void anySingle@@ -129,8 +137,7 @@ -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0--indentLevel :: MonadParsec e s m => m Pos+indentLevel :: (TraversableStream s, MonadParsec e s m) => m Pos indentLevel = sourceColumn <$> getSourcePos {-# INLINE indentLevel #-} @@ -142,14 +149,18 @@ -- * Actual indentation level -- -- @since 5.0.0--incorrectIndent :: MonadParsec e s m- => Ordering -- ^ Desired ordering between reference level and actual level- -> Pos -- ^ Reference indentation level- -> Pos -- ^ Actual indentation level- -> m a-incorrectIndent ord ref actual = fancyFailure . E.singleton $- ErrorIndentation ord ref actual+incorrectIndent ::+ MonadParsec e s m =>+ -- | Desired ordering between reference level and actual level+ Ordering ->+ -- | Reference indentation level+ Pos ->+ -- | Actual indentation level+ Pos ->+ m a+incorrectIndent ord ref actual =+ fancyFailure . E.singleton $+ ErrorIndentation ord ref actual {-# INLINEABLE incorrectIndent #-} -- | @'indentGuard' spaceConsumer ord ref@ first consumes all white space@@ -162,12 +173,16 @@ -- arguments like @'indentGuard' spaceConsumer 'GT' 'pos1'@—this will make -- sure you have some indentation. Use returned value to check indentation -- on every subsequent line according to syntax of your language.--indentGuard :: MonadParsec e s m- => m () -- ^ How to consume indentation (white space)- -> Ordering -- ^ Desired ordering between reference level and actual level- -> Pos -- ^ Reference indentation level- -> m Pos -- ^ Current column (indentation level)+indentGuard ::+ (TraversableStream s, MonadParsec e s m) =>+ -- | How to consume indentation (white space)+ m () ->+ -- | Desired ordering between reference level and actual level+ Ordering ->+ -- | Reference indentation level+ Pos ->+ -- | Current column (indentation level)+ m Pos indentGuard sc ord ref = do sc actual <- indentLevel@@ -181,11 +196,13 @@ -- top-level function definitions. -- -- @since 4.3.0--nonIndented :: MonadParsec e s m- => m () -- ^ How to consume indentation (white space)- -> m a -- ^ How to parse actual data- -> m a+nonIndented ::+ (TraversableStream s, MonadParsec e s m) =>+ -- | How to consume indentation (white space)+ m () ->+ -- | How to parse actual data+ m a ->+ m a nonIndented sc p = indentGuard sc EQ pos1 *> p {-# INLINEABLE nonIndented #-} @@ -193,18 +210,17 @@ -- 'indentBlock', which see. -- -- @since 4.3.0- data IndentOpt m a b- = IndentNone a- -- ^ Parse no indented tokens, just return the value- | IndentMany (Maybe Pos) ([b] -> m a) (m b)- -- ^ Parse many indented tokens (possibly zero), use given indentation+ = -- | Parse no indented tokens, just return the value+ IndentNone a+ | -- | Parse many indented tokens (possibly zero), use given indentation -- level (if 'Nothing', use level of the first indented token); the -- second argument tells how to get the final result, and the third -- argument describes how to parse an indented token- | IndentSome (Maybe Pos) ([b] -> m a) (m b)- -- ^ Just like 'IndentMany', but requires at least one indented token to+ IndentMany (Maybe Pos) ([b] -> m a) (m b)+ | -- | Just like 'IndentMany', but requires at least one indented token to -- be present+ IndentSome (Maybe Pos) ([b] -> m a) (m b) -- | Parse a “reference” token and a number of other tokens that have -- greater (but the same) level of indentation than that of “reference”@@ -216,15 +232,17 @@ -- space characters. -- -- @since 4.3.0--indentBlock :: (MonadParsec e s m, Token s ~ Char)- => m () -- ^ How to consume indentation (white space)- -> m (IndentOpt m a b) -- ^ How to parse “reference” token- -> m a+indentBlock ::+ (TraversableStream s, MonadParsec e s m, Token s ~ Char) =>+ -- | How to consume indentation (white space)+ m () ->+ -- | How to parse “reference” token+ m (IndentOpt m a b) ->+ m a indentBlock sc r = do sc ref <- indentLevel- a <- r+ a <- r case a of IndentNone x -> x <$ sc IndentMany indent f p -> do@@ -237,33 +255,41 @@ IndentSome indent f p -> do pos <- C.eol *> indentGuard sc GT ref let lvl = fromMaybe pos indent- x <- if | pos <= ref -> incorrectIndent GT ref pos- | pos == lvl -> p- | otherwise -> incorrectIndent EQ lvl pos- xs <- indentedItems ref lvl sc p- f (x:xs)+ x <-+ if+ | 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 #-} -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of the public API.--indentedItems :: MonadParsec e s m- => Pos -- ^ Reference indentation level- -> Pos -- ^ Level of the first indented item ('lookAhead'ed)- -> m () -- ^ How to consume indentation (white space)- -> m b -- ^ How to parse indented tokens- -> m [b]+indentedItems ::+ (TraversableStream s, MonadParsec e s m) =>+ -- | Reference indentation level+ Pos ->+ -- | Level of the first indented item ('lookAhead'ed)+ Pos ->+ -- | How to consume indentation (white space)+ m () ->+ -- | How to parse indented tokens+ m b ->+ m [b] indentedItems ref lvl sc p = go where go = do sc- pos <- indentLevel+ pos <- indentLevel done <- isJust <$> optional eof if done then return []- else if | pos <= ref -> return []- | pos == lvl -> (:) <$> p <*> go- | otherwise -> incorrectIndent EQ lvl pos+ else+ if+ | 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/@@ -282,11 +308,13 @@ -- > L.symbol sc "baz" -- for the last symbol we use normal space consumer -- -- @since 5.0.0--lineFold :: MonadParsec e s m- => m () -- ^ How to consume indentation (white space)- -> (m () -> m a) -- ^ Callback that uses provided space-consumer- -> m a+lineFold ::+ (TraversableStream s, MonadParsec e s m) =>+ -- | How to consume indentation (white space)+ m () ->+ -- | Callback that uses provided space-consumer+ (m () -> m a) ->+ m a lineFold sc action = sc >> indentLevel >>= action . void . indentGuard sc GT {-# INLINEABLE lineFold #-}@@ -310,7 +338,6 @@ -- -- __Performance note__: the parser is not particularly efficient at the -- moment.- charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint,@@ -318,7 +345,7 @@ r <- lookAhead (count' 1 10 anySingle) case listToMaybe (Char.readLitChar r) of Just (c, r') -> c <$ skipCount (length r - length r') anySingle- Nothing -> unexpected (Tokens (head r:|[]))+ Nothing -> unexpected (Tokens (head r :| [])) {-# INLINEABLE charLiteral #-} ----------------------------------------------------------------------------@@ -329,21 +356,20 @@ -- -- If you need to parse signed integers, see the 'signed' combinator. ----- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it--- wasn't polymorphic in its return type.-+-- __Note__: before the version /6.0.0/ the function returned 'Integer',+-- i.e. it wasn't polymorphic in its return type. decimal :: (MonadParsec e s m, Token s ~ Char, Num a) => m a decimal = decimal_ <?> "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers.--decimal_- :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a)- => m a+decimal_ ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Char, Num a) =>+ m a decimal_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 10 + fromIntegral (Char.digitToInt c) {-# INLINE decimal_ #-} @@ -355,16 +381,17 @@ -- > binary = char '0' >> char' 'b' >> L.binary -- -- @since 7.0.0--binary- :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a)- => m a-binary = mkNum- <$> takeWhile1P Nothing isBinDigit- <?> "binary integer"+binary ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Char, Num a) =>+ m a+binary =+ mkNum+ <$> takeWhile1P Nothing isBinDigit+ <?> "binary integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)- step a c = a * 2 + fromIntegral (Char.digitToInt c)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a c = a * 2 + fromIntegral (Char.digitToInt c) isBinDigit x = x == '0' || x == '1' {-# INLINEABLE binary #-} @@ -378,17 +405,18 @@ -- -- > octal = char '0' >> char' 'o' >> L.octal ----- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it+-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type.--octal- :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a)- => m a-octal = mkNum- <$> takeWhile1P Nothing Char.isOctDigit- <?> "octal integer"+octal ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Char, Num a) =>+ m a+octal =+ mkNum+ <$> takeWhile1P Nothing Char.isOctDigit+ <?> "octal integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 8 + fromIntegral (Char.digitToInt c) {-# INLINEABLE octal #-} @@ -402,17 +430,18 @@ -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal ----- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it+-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type.--hexadecimal- :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a)- => m a-hexadecimal = mkNum- <$> takeWhile1P Nothing Char.isHexDigit- <?> "hexadecimal integer"+hexadecimal ::+ forall e s m a.+ (MonadParsec e s m, Token s ~ Char, Num a) =>+ m a+hexadecimal =+ mkNum+ <$> takeWhile1P Nothing Char.isHexDigit+ <?> "hexadecimal integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 16 + fromIntegral (Char.digitToInt c) {-# INLINEABLE hexadecimal #-} @@ -428,14 +457,14 @@ -- see 'signed'. -- -- @since 5.0.0--scientific- :: forall e s m. (MonadParsec e s m, Token s ~ Char)- => m Scientific+scientific ::+ forall e s m.+ (MonadParsec e s m, Token s ~ Char) =>+ m Scientific scientific = do- c' <- decimal_+ c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c')- e <- option e' (try $ exponent_ e')+ e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -447,37 +476,43 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. ----- __Note__: before version 6.0.0 the function returned 'Double', i.e. it+-- __Note__: before version /6.0.0/ the function returned 'Double', i.e. it -- wasn't polymorphic in its return type. ----- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers.-+-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain+-- integers. float :: (MonadParsec e s m, Token s ~ Char, RealFloat a) => m a float = do c' <- decimal_- Sci.toRealFloat <$>- ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c'- e <- option e' (try $ exponent_ e')- return (Sci.scientific c e))- <|> (Sci.scientific c' <$> exponent_ 0))+ Sci.toRealFloat+ <$> ( ( do+ SP c e' <- dotDecimal_ (Proxy :: Proxy s) c'+ e <- option e' (try $ exponent_ e')+ return (Sci.scientific c e)+ )+ <|> (Sci.scientific c' <$> exponent_ 0)+ ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Char)- => Proxy s- -> Integer- -> m SP+dotDecimal_ ::+ (MonadParsec e s m, Token s ~ Char) =>+ Proxy s ->+ Integer ->+ m SP dotDecimal_ pxy c' = do void (C.char '.')- let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy- step (SP a e') c = SP- (a * 10 + fromIntegral (Char.digitToInt c))- (e' - 1)+ let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+ step (SP a e') c =+ SP+ (a * 10 + fromIntegral (Char.digitToInt c))+ (e' - 1) mkNum <$> takeWhile1P (Just "digit") Char.isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Char)- => Int- -> m Int+exponent_ ::+ (MonadParsec e s m, Token s ~ Char) =>+ Int ->+ m Int exponent_ e' = do void (C.char' 'e') (+ e') <$> signed (return ()) decimal_@@ -494,11 +529,14 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer--signed :: (MonadParsec e s m, Token s ~ Char, Num a)- => m () -- ^ How to consume white space after the sign- -> m a -- ^ How to parse the number itself- -> m a -- ^ Parser for signed numbers+signed ::+ (MonadParsec e s m, Token s ~ Char, Num a) =>+ -- | How to consume white space after the sign+ m () ->+ -- | How to parse the number itself+ m a ->+ -- | Parser for signed numbers+ m a signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ C.char '+') <|> (negate <$ C.char '-')
Text/Megaparsec/Class.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Class -- Copyright : © 2015–present Megaparsec contributors@@ -13,31 +19,25 @@ -- the full set of primitive parsers. -- -- @since 6.5.0--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec.Class- ( MonadParsec (..) )+ ( MonadParsec (..),+ ) where import Control.Monad import Control.Monad.Identity+import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S import Control.Monad.Trans+import qualified Control.Monad.Trans.Reader as L+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.Strict as S import Data.Set (Set) import Text.Megaparsec.Error import Text.Megaparsec.State import Text.Megaparsec.Stream-import qualified Control.Monad.RWS.Lazy as L-import qualified Control.Monad.RWS.Strict as S-import qualified Control.Monad.Trans.Reader as L-import qualified Control.Monad.Trans.State.Lazy as L-import qualified Control.Monad.Trans.State.Strict as S-import qualified Control.Monad.Trans.Writer.Lazy as L-import qualified Control.Monad.Trans.Writer.Strict as S -- | Type class describing monads that implement the full set of primitive -- parsers.@@ -45,28 +45,23 @@ -- __Note__ that the following primitives are “fast” and should be taken -- advantage of as much as possible if your aim is a fast parser: 'tokens', -- 'takeWhileP', 'takeWhile1P', and 'takeP'.- class (Stream s, MonadPlus m) => MonadParsec e s m | m -> e s where- -- | Stop parsing and report the 'ParseError'. This is the only way to -- control position of the error without manipulating parser state -- manually. -- -- @since 8.0.0- parseError :: ParseError s e -> m a -- | The parser @'label' name p@ behaves as parser @p@, but whenever the -- parser @p@ fails /without consuming any input/, it replaces names of -- “expected” tokens with the name @name@.- label :: String -> m a -> m a -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any -- “expected” tokens in error message when @p@ fails. -- -- Please use 'hidden' instead of the old @'label' ""@ idiom.- hidden :: m a -> m a hidden = label "" @@ -108,7 +103,6 @@ -- However, the examples above demonstrate the idea behind 'try' so well -- that it was decided to keep them. You still need to use 'try' when your -- alternatives are complex, composite parsers.- try :: m a -> m a -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not)@@ -116,13 +110,11 @@ -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no -- effect, i.e. it will fail consuming input if @p@ fails consuming input. -- Combine with 'try' if this is undesirable.- lookAhead :: m a -> m a -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This -- parser /never consumes/ any input and /never modifies/ parser state. It -- can be used to implement the “longest match” rule.- notFollowedBy :: m a -> m () -- | @'withRecovery' r p@ allows continue parsing even if parser @p@@@ -136,11 +128,13 @@ -- error messages. -- -- @since 4.4.0-- withRecovery- :: (ParseError s e -> m a) -- ^ How to recover from failure- -> m a -- ^ Original parser- -> m a -- ^ Parser that can recover from failures+ withRecovery ::+ -- | How to recover from failure+ (ParseError s e -> m a) ->+ -- | Original parser+ m a ->+ -- | Parser that can recover from failures+ m a -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should -- it happen, without actually ending parsing but instead getting the@@ -150,13 +144,12 @@ -- parser works in any way. -- -- @since 5.1.0-- observing- :: m a -- ^ The parser to run- -> m (Either (ParseError s e) a)+ observing ::+ -- | The parser to run+ m a ->+ m (Either (ParseError s e) a) -- | This parser only succeeds at the end of input.- eof :: m () -- | The parser @'token' test expected@ accepts a token @t@ with result@@ -172,13 +165,12 @@ -- -- __Note__: type signature of this primitive was changed in the version -- /7.0.0/.-- token- :: (Token s -> Maybe a)- -- ^ Matching function for the token to parse- -> Set (ErrorItem (Token s))- -- ^ Expected items (in case of an error)- -> m a+ token ::+ -- | Matching function for the token to parse+ (Token s -> Maybe a) ->+ -- | Expected items (in case of an error)+ Set (ErrorItem (Token s)) ->+ m a -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and -- returns it. The supplied predicate @test@ is used to check equality of@@ -204,13 +196,12 @@ -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect -- performance in any way.-- tokens- :: (Tokens s -> Tokens s -> Bool)- -- ^ Predicate to check equality of chunks- -> Tokens s- -- ^ Chunk of input to match against- -> m (Tokens s)+ tokens ::+ -- | Predicate to check equality of chunks+ (Tokens s -> Tokens s -> Bool) ->+ -- | Chunk of input to match against+ Tokens s ->+ m (Tokens s) -- | Parse /zero/ or more tokens for which the supplied predicate holds. -- Try to use this as much as possible because for many streams the@@ -225,22 +216,26 @@ -- The combinator never fails, although it may parse the empty chunk. -- -- @since 6.0.0-- takeWhileP- :: Maybe String -- ^ Name for a single token in the row- -> (Token s -> Bool) -- ^ Predicate to use to test tokens- -> m (Tokens s) -- ^ A chunk of matching tokens+ takeWhileP ::+ -- | Name for a single token in the row+ Maybe String ->+ -- | Predicate to use to test tokens+ (Token s -> Bool) ->+ -- | A chunk of matching tokens+ m (Tokens s) -- | Similar to 'takeWhileP', but fails if it can't parse at least one -- token. Note that the combinator either succeeds or fails without -- consuming any input, so 'try' is not necessary with it. -- -- @since 6.0.0-- takeWhile1P- :: Maybe String -- ^ Name for a single token in the row- -> (Token s -> Bool) -- ^ Predicate to use to test tokens- -> m (Tokens s) -- ^ A chunk of matching tokens+ takeWhile1P ::+ -- | Name for a single token in the row+ Maybe String ->+ -- | Predicate to use to test tokens+ (Token s -> Bool) ->+ -- | A chunk of matching tokens+ m (Tokens s) -- | Extract the specified number of tokens from the input stream and -- return them packed as a chunk of stream. If there is not enough tokens@@ -249,207 +244,214 @@ -- -- The parser is roughly equivalent to: --- -- > takeP (Just "foo") n = count n (anyChar <?> "foo")- -- > takeP Nothing n = count n anyChar+ -- > takeP (Just "foo") n = count n (anySingle <?> "foo")+ -- > takeP Nothing n = count n anySingle -- -- Note that if the combinator fails due to insufficient number of tokens -- in the input stream, it backtracks automatically. No 'try' is necessary -- with 'takeP'. -- -- @since 6.0.0-- takeP- :: Maybe String -- ^ Name for a single token in the row- -> Int -- ^ How many tokens to extract- -> m (Tokens s) -- ^ A chunk of matching tokens+ takeP ::+ -- | Name for a single token in the row+ Maybe String ->+ -- | How many tokens to extract+ Int ->+ -- | A chunk of matching tokens+ m (Tokens s) -- | Return the full parser state as a 'State' record.- getParserState :: m (State s e) -- | @'updateParserState' f@ applies the function @f@ to the parser state.- updateParserState :: (State s e -> State s e) -> m () ---------------------------------------------------------------------------- -- Lifting through MTL instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where- parseError e = lift (parseError e)- 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 ->+ parseError e = lift (parseError e)+ 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 -> (,s) . fst <$> lookAhead (m s) notFollowedBy (L.StateT m) = L.StateT $ \s ->- notFollowedBy (fst <$> m s) >> return ((),s)+ notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (L.StateT m) = L.StateT $ \s -> withRecovery (\e -> L.runStateT (r e) s) (m s)- observing (L.StateT m) = L.StateT $ \s ->+ observing (L.StateT m) = L.StateT $ \s -> fixs s <$> observing (m s)- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where- parseError e = lift (parseError e)- 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 ->+ parseError e = lift (parseError e)+ 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 -> (,s) . fst <$> lookAhead (m s) notFollowedBy (S.StateT m) = S.StateT $ \s ->- notFollowedBy (fst <$> m s) >> return ((),s)+ notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (S.StateT m) = S.StateT $ \s -> withRecovery (\e -> S.runStateT (r e) s) (m s)- observing (S.StateT m) = S.StateT $ \s ->+ observing (S.StateT m) = S.StateT $ \s -> fixs s <$> observing (m s)- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where- parseError e = lift (parseError e)- 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+ parseError e = lift (parseError e)+ 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 notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> withRecovery (\e -> L.runReaderT (r e) s) (m s)- observing (L.ReaderT m) = L.ReaderT $ observing . m- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ observing (L.ReaderT m) = L.ReaderT $ observing . m+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where- parseError e = lift (parseError e)- label n (L.WriterT m) = L.WriterT $ label n m- try (L.WriterT m) = L.WriterT $ try m- lookAhead (L.WriterT m) = L.WriterT $- (,mempty) . fst <$> lookAhead m- notFollowedBy (L.WriterT m) = L.WriterT $- (,mempty) <$> notFollowedBy (fst <$> m)- withRecovery r (L.WriterT m) = L.WriterT $- withRecovery (L.runWriterT . r) m- observing (L.WriterT m) = L.WriterT $- fixs mempty <$> observing m- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ parseError e = lift (parseError e)+ label n (L.WriterT m) = L.WriterT $ label n m+ try (L.WriterT m) = L.WriterT $ try m+ lookAhead (L.WriterT m) =+ L.WriterT $+ (,mempty) . fst <$> lookAhead m+ notFollowedBy (L.WriterT m) =+ L.WriterT $+ (,mempty) <$> notFollowedBy (fst <$> m)+ withRecovery r (L.WriterT m) =+ L.WriterT $+ withRecovery (L.runWriterT . r) m+ observing (L.WriterT m) =+ L.WriterT $+ fixs mempty <$> observing m+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where- parseError e = lift (parseError e)- label n (S.WriterT m) = S.WriterT $ label n m- try (S.WriterT m) = S.WriterT $ try m- lookAhead (S.WriterT m) = S.WriterT $- (,mempty) . fst <$> lookAhead m- notFollowedBy (S.WriterT m) = S.WriterT $- (,mempty) <$> notFollowedBy (fst <$> m)- withRecovery r (S.WriterT m) = S.WriterT $- withRecovery (S.runWriterT . r) m- observing (S.WriterT m) = S.WriterT $- fixs mempty <$> observing m- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ parseError e = lift (parseError e)+ label n (S.WriterT m) = S.WriterT $ label n m+ try (S.WriterT m) = S.WriterT $ try m+ lookAhead (S.WriterT m) =+ S.WriterT $+ (,mempty) . fst <$> lookAhead m+ notFollowedBy (S.WriterT m) =+ S.WriterT $+ (,mempty) <$> notFollowedBy (fst <$> m)+ withRecovery r (S.WriterT m) =+ S.WriterT $+ withRecovery (S.runWriterT . r) m+ observing (S.WriterT m) =+ S.WriterT $+ fixs mempty <$> observing m+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) -- | @since 5.2.0- instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where- parseError e = lift (parseError e)- 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- (x,_,_) <- lookAhead (m r s)- return (x,s,mempty)- notFollowedBy (L.RWST m) = L.RWST $ \r s -> do+ parseError e = lift (parseError e)+ 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+ (x, _, _) <- lookAhead (m r s)+ return (x, s, mempty)+ notFollowedBy (L.RWST m) = L.RWST $ \r s -> do notFollowedBy (void $ m r s)- return ((),s,mempty)- withRecovery n (L.RWST m) = L.RWST $ \r s ->+ return ((), s, mempty)+ withRecovery n (L.RWST m) = L.RWST $ \r s -> withRecovery (\e -> L.runRWST (n e) r s) (m r s)- observing (L.RWST m) = L.RWST $ \r s ->+ observing (L.RWST m) = L.RWST $ \r s -> fixs' s <$> observing (m r s)- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) -- | @since 5.2.0- instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where- parseError e = lift (parseError e)- 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- (x,_,_) <- lookAhead (m r s)- return (x,s,mempty)- notFollowedBy (S.RWST m) = S.RWST $ \r s -> do+ parseError e = lift (parseError e)+ 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+ (x, _, _) <- lookAhead (m r s)+ return (x, s, mempty)+ notFollowedBy (S.RWST m) = S.RWST $ \r s -> do notFollowedBy (void $ m r s)- return ((),s,mempty)- withRecovery n (S.RWST m) = S.RWST $ \r s ->+ return ((), s, mempty)+ withRecovery n (S.RWST m) = S.RWST $ \r s -> withRecovery (\e -> S.runRWST (n e) r s) (m r s)- observing (S.RWST m) = S.RWST $ \r s ->+ observing (S.RWST m) = S.RWST $ \r s -> fixs' s <$> observing (m r s)- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift (tokens e ts)- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift (updateParserState f)+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift (tokens e ts)+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (IdentityT m) where- parseError e = lift (parseError e)- label n (IdentityT m) = IdentityT $ label n m- try = IdentityT . try . runIdentityT- lookAhead (IdentityT m) = IdentityT $ lookAhead m+ parseError e = lift (parseError e)+ label n (IdentityT m) = IdentityT $ label n m+ try = IdentityT . try . runIdentityT+ lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m- withRecovery r (IdentityT m) = IdentityT $- withRecovery (runIdentityT . r) m- observing (IdentityT m) = IdentityT $ observing m- eof = lift eof- token test mt = lift (token test mt)- tokens e ts = lift $ tokens e ts- takeWhileP l f = lift (takeWhileP l f)- takeWhile1P l f = lift (takeWhile1P l f)- takeP l n = lift (takeP l n)- getParserState = lift getParserState- updateParserState f = lift $ updateParserState f+ withRecovery r (IdentityT m) =+ IdentityT $+ withRecovery (runIdentityT . r) m+ observing (IdentityT m) = IdentityT $ observing m+ eof = lift eof+ token test mt = lift (token test mt)+ tokens e ts = lift $ tokens e ts+ takeWhileP l f = lift (takeWhileP l f)+ takeWhile1P l f = lift (takeWhile1P l f)+ takeP l n = lift (takeP l n)+ getParserState = lift getParserState+ updateParserState f = lift $ updateParserState f fixs :: s -> Either a (b, s) -> (Either a b, s)-fixs s (Left a) = (Left a, s)+fixs s (Left a) = (Left a, s) fixs _ (Right (b, s)) = (Right b, s) {-# INLINE fixs #-} fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w)-fixs' s (Left a) = (Left a, s, mempty)-fixs' _ (Right (b,s,w)) = (Right b, s, w)+fixs' s (Left a) = (Left a, s, mempty)+fixs' _ (Right (b, s, w)) = (Right b, s, w) {-# INLINE fixs' #-}
Text/Megaparsec/Common.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors@@ -11,20 +13,17 @@ -- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". -- -- @since 7.0.0--{-# LANGUAGE FlexibleContexts #-}- module Text.Megaparsec.Common- ( string- , string' )+ ( string,+ string',+ ) where +import qualified Data.CaseInsensitive as CI import Data.Function (on) import Text.Megaparsec-import qualified Data.CaseInsensitive as CI -- | A synonym for 'chunk'.- string :: MonadParsec e s m => Tokens s -> m (Tokens s) string = chunk {-# INLINE string #-}@@ -34,9 +33,9 @@ -- -- >>> parseTest (string' "foobar") "foObAr" -- "foObAr"--string' :: (MonadParsec e s m, CI.FoldCase (Tokens s))- => Tokens s- -> m (Tokens s)+string' ::+ (MonadParsec e s m, CI.FoldCase (Tokens s)) =>+ Tokens s ->+ m (Tokens s) string' = tokens ((==) `on` CI.mk) {-# INLINE string' #-}
Text/Megaparsec/Debug.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- Module : Text.Megaparsec.Debug -- Copyright : © 2015–present Megaparsec contributors@@ -10,21 +13,18 @@ -- Debugging helpers. -- -- @since 7.0.0--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Text.Megaparsec.Debug- ( dbg )+ ( dbg,+ ) where +import qualified Data.List.NonEmpty as NE import Data.Proxy import Debug.Trace import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.State import Text.Megaparsec.Stream-import qualified Data.List.NonEmpty as NE -- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated -- it also prints information useful for debugging. The @label@ is only used@@ -54,84 +54,94 @@ -- 'Show' instance for state), so this helper is only available for -- 'ParsecT' monad, not any instance of 'Text.Megaparsec.MonadParsec' in -- general.--dbg :: forall e s m a.- ( Stream s- , ShowErrorComponent e- , Show a )- => String -- ^ Debugging label- -> ParsecT e s m a -- ^ Parser to debug- -> ParsecT e s m a -- ^ Parser that prints debugging messages+dbg ::+ forall e s m a.+ ( VisualStream s,+ ShowErrorComponent e,+ Show a+ ) =>+ -- | Debugging label+ String ->+ -- | Parser to debug+ ParsecT e s m a ->+ -- | Parser that prints debugging messages+ ParsecT e s m a dbg lbl p = ParsecT $ \s cok cerr eok eerr -> let l = dbgLog lbl :: DbgItem s e a -> String unfold = streamTake 40- cok' x s' hs = flip trace (cok x s' hs) $- l (DbgIn (unfold (stateInput s))) ++- l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)- cerr' err s' = flip trace (cerr err s') $- l (DbgIn (unfold (stateInput s))) ++- l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)- eok' x s' hs = flip trace (eok x s' hs) $- l (DbgIn (unfold (stateInput s))) ++- l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)- eerr' err s' = flip trace (eerr err s') $- l (DbgIn (unfold (stateInput s))) ++- l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)- in unParser p s cok' cerr' eok' eerr'+ cok' x s' hs =+ flip trace (cok x s' hs) $+ l (DbgIn (unfold (stateInput s)))+ ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)+ cerr' err s' =+ flip trace (cerr err s') $+ l (DbgIn (unfold (stateInput s)))+ ++ l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)+ eok' x s' hs =+ flip trace (eok x s' hs) $+ l (DbgIn (unfold (stateInput s)))+ ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)+ eerr' err s' =+ flip trace (eerr err s') $+ l (DbgIn (unfold (stateInput s)))+ ++ l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)+ in unParser p s cok' cerr' eok' eerr' -- | A single piece of info to be rendered with 'dbgLog'.- data DbgItem s e a- = DbgIn [Token s]- | DbgCOK [Token s] a+ = DbgIn [Token s]+ | DbgCOK [Token s] a | DbgCERR [Token s] (ParseError s e)- | DbgEOK [Token s] a+ | DbgEOK [Token s] a | DbgEERR [Token s] (ParseError s e) -- | Render a single piece of debugging info.--dbgLog- :: forall s e a. (Stream s, ShowErrorComponent e, Show a)- => String -- ^ Debugging label- -> DbgItem s e a -- ^ Information to render- -> String -- ^ Rendered result+dbgLog ::+ forall s e a.+ (VisualStream s, ShowErrorComponent e, Show a) =>+ -- | Debugging label+ String ->+ -- | Information to render+ DbgItem s e a ->+ -- | Rendered result+ String dbgLog lbl item = prefix msg where prefix = unlines . fmap ((lbl ++ "> ") ++) . lines pxy = Proxy :: Proxy s msg = case item of- DbgIn ts ->+ DbgIn ts -> "IN: " ++ showStream pxy ts- DbgCOK ts a ->+ DbgCOK ts a -> "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a DbgCERR ts e -> "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e- DbgEOK ts a ->+ DbgEOK ts a -> "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a DbgEERR ts e -> "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e -- | Pretty-print a list of tokens.--showStream :: Stream s => Proxy s -> [Token s] -> String+showStream :: VisualStream s => Proxy s -> [Token s] -> String showStream pxy ts = case NE.nonEmpty ts of Nothing -> "<EMPTY>" Just ne -> let (h, r) = splitAt 40 (showTokens pxy ne)- in if null r then h else h ++ " <…>"+ in if null r then h else h ++ " <…>" -- | Calculate number of consumed tokens given 'State' of parser before and -- after parsing.--streamDelta- :: State s e -- ^ State of parser before consumption- -> State s e -- ^ State of parser after consumption- -> Int -- ^ Number of consumed tokens+streamDelta ::+ -- | State of parser before consumption+ State s e ->+ -- | State of parser after consumption+ State s e ->+ -- | Number of consumed tokens+ Int streamDelta s0 s1 = stateOffset s1 - stateOffset s0 -- | Extract a given number of tokens from the stream.- streamTake :: forall s. Stream s => Int -> s -> [Token s] streamTake n s = case fst <$> takeN_ n s of
Text/Megaparsec/Error.hs view
@@ -1,3 +1,15 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Error -- Copyright : © 2015–present Megaparsec contributors@@ -14,34 +26,23 @@ -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway.--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec.Error ( -- * Parse error type- ErrorItem (..)- , ErrorFancy (..)- , ParseError (..)- , mapParseError- , errorOffset- , setErrorOffset- , ParseErrorBundle (..)- , attachSourcePos+ ErrorItem (..),+ ErrorFancy (..),+ ParseError (..),+ mapParseError,+ errorOffset,+ setErrorOffset,+ ParseErrorBundle (..),+ attachSourcePos,+ -- * Pretty-printing- , ShowErrorComponent (..)- , errorBundlePretty- , parseErrorPretty- , parseErrorTextPretty )+ ShowErrorComponent (..),+ errorBundlePretty,+ parseErrorPretty,+ parseErrorTextPretty,+ ) where import Control.DeepSeq@@ -50,17 +51,17 @@ import Data.Data (Data) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Maybe (isNothing) import Data.Proxy import Data.Set (Set)+import qualified Data.Set as E import Data.Typeable (Typeable) import Data.Void import GHC.Generics import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E ---------------------------------------------------------------------------- -- Parse error type@@ -69,11 +70,13 @@ -- 'ParseError'. The data type is parametrized over the token type @t@. -- -- @since 5.0.0- data ErrorItem t- = Tokens (NonEmpty t) -- ^ Non-empty stream of tokens- | Label (NonEmpty Char) -- ^ Label (cannot be empty)- | EndOfInput -- ^ End of input+ = -- | Non-empty stream of tokens+ Tokens (NonEmpty t)+ | -- | Label (cannot be empty)+ Label (NonEmpty Char)+ | -- | End of input+ EndOfInput deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) instance NFData t => NFData (ErrorItem t)@@ -83,16 +86,15 @@ -- 'ErrorCustom' constructor. -- -- @since 6.0.0- data ErrorFancy e- = ErrorFail String- -- ^ 'fail' has been used in parser monad- | ErrorIndentation Ordering Pos Pos- -- ^ Incorrect indentation error: desired ordering between reference+ = -- | 'fail' has been used in parser monad+ ErrorFail String+ | -- | Incorrect indentation error: desired ordering between reference -- level and actual level, reference indentation level, actual -- indentation level- | ErrorCustom e- -- ^ Custom error data+ ErrorIndentation Ordering Pos Pos+ | -- | Custom error data+ ErrorCustom e deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) instance NFData a => NFData (ErrorFancy a) where@@ -110,82 +112,90 @@ -- fancy errors take precedence over trivial errors in merging. -- -- @since 7.0.0- data ParseError s e- = TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))- -- ^ Trivial errors, generated by Megaparsec's machinery. The data+ = -- | Trivial errors, generated by Megaparsec's machinery. The data -- constructor includes the offset of error, unexpected token (if any), -- and expected tokens. -- -- Type of the first argument was changed in the version /7.0.0/.- | FancyError Int (Set (ErrorFancy e))- -- ^ Fancy, custom errors.+ TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))+ | -- | Fancy, custom errors. -- -- Type of the first argument was changed in the version /7.0.0/.+ FancyError Int (Set (ErrorFancy e)) deriving (Typeable, Generic) -deriving instance ( Show (Token s)- , Show e- ) => Show (ParseError s e)+deriving instance+ ( Show (Token s),+ Show e+ ) =>+ Show (ParseError s e) -deriving instance ( Eq (Token s)- , Eq e- ) => Eq (ParseError s e)+deriving instance+ ( Eq (Token s),+ Eq e+ ) =>+ Eq (ParseError s e) -deriving instance ( Data s- , Data (Token s)- , Ord (Token s)- , Data e- , Ord e- ) => Data (ParseError s e)+deriving instance+ ( Data s,+ Data (Token s),+ Ord (Token s),+ Data e,+ Ord e+ ) =>+ Data (ParseError s e) -instance ( NFData (Token s)- , NFData e- ) => NFData (ParseError s e)+instance+ ( NFData (Token s),+ NFData e+ ) =>+ NFData (ParseError s e) instance (Stream s, Ord e) => Semigroup (ParseError s e) where (<>) = mergeError {-# INLINE (<>) #-} instance (Stream s, Ord e) => Monoid (ParseError s e) where- mempty = TrivialError 0 Nothing E.empty+ mempty = TrivialError 0 Nothing E.empty mappend = (<>) {-# INLINE mappend #-} -instance ( Show s- , Show (Token s)- , Show e- , ShowErrorComponent e- , Stream s- , Typeable s- , Typeable e )- => Exception (ParseError s e) where+instance+ ( Show s,+ Show (Token s),+ Show e,+ ShowErrorComponent e,+ VisualStream s,+ Typeable s,+ Typeable e+ ) =>+ Exception (ParseError s e)+ where displayException = parseErrorPretty -- | Modify the custom data component in a parse error. This could be done -- via 'fmap' if not for the 'Ord' constraint. -- -- @since 7.0.0--mapParseError :: Ord e'- => (e -> e')- -> ParseError s e- -> ParseError s e'+mapParseError ::+ Ord e' =>+ (e -> e') ->+ ParseError s e ->+ ParseError s e' mapParseError _ (TrivialError o u p) = TrivialError o u p mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) -- | Get offset of 'ParseError'. -- -- @since 7.0.0- errorOffset :: ParseError s e -> Int errorOffset (TrivialError o _ _) = o-errorOffset (FancyError o _) = o+errorOffset (FancyError o _) = o -- | Set offset of 'ParseError'. -- -- @since 8.0.0- setErrorOffset :: Int -> ParseError s e -> ParseError s e setErrorOffset o (TrivialError _ u p) = TrivialError o u p setErrorOffset o (FancyError _ x) = FancyError o x@@ -195,11 +205,11 @@ -- 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.--mergeError :: (Stream s, Ord e)- => ParseError s e- -> ParseError s e- -> ParseError s e+mergeError ::+ (Stream s, Ord e) =>+ ParseError s e ->+ ParseError s e ->+ ParseError s e mergeError e1 e2 = case errorOffset e1 `compare` errorOffset e2 of LT -> e2@@ -221,7 +231,7 @@ -- arbitrary, but is necessary because otherwise we can't make -- ParseError lawful Monoid and have nice parse errors at the same -- time).- n Nothing Nothing = Nothing+ n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y)@@ -231,49 +241,63 @@ -- allows to pretty-print the errors efficiently and correctly. -- -- @since 7.0.0- data ParseErrorBundle s e = ParseErrorBundle- { bundleErrors :: NonEmpty (ParseError s e)- -- ^ A collection of 'ParseError's that is sorted by parse error offsets- , bundlePosState :: PosState s- -- ^ State that is used for line\/column calculation- } deriving (Generic)+ { -- | A collection of 'ParseError's that is sorted by parse error offsets+ bundleErrors :: NonEmpty (ParseError s e),+ -- | State that is used for line\/column calculation+ bundlePosState :: PosState s+ }+ deriving (Generic) -deriving instance ( Show s- , Show (Token s)- , Show e- ) => Show (ParseErrorBundle s e)+deriving instance+ ( Show s,+ Show (Token s),+ Show e+ ) =>+ Show (ParseErrorBundle s e) -deriving instance ( Eq s- , Eq (Token s)- , Eq e- ) => Eq (ParseErrorBundle s e)+deriving instance+ ( Eq s,+ Eq (Token s),+ Eq e+ ) =>+ Eq (ParseErrorBundle s e) -deriving instance ( Typeable s- , Typeable (Token s)- , Typeable e- ) => Typeable (ParseErrorBundle s e)+deriving instance+ ( Typeable s,+ Typeable (Token s),+ Typeable e+ ) =>+ Typeable (ParseErrorBundle s e) -deriving instance ( Data s- , Data (Token s)- , Ord (Token s)- , Data e- , Ord e- ) => Data (ParseErrorBundle s e)+deriving instance+ ( Data s,+ Data (Token s),+ Ord (Token s),+ Data e,+ Ord e+ ) =>+ Data (ParseErrorBundle s e) -instance ( NFData s- , NFData (Token s)- , NFData e- ) => NFData (ParseErrorBundle s e)+instance+ ( NFData s,+ NFData (Token s),+ NFData e+ ) =>+ NFData (ParseErrorBundle s e) -instance ( Show s- , Show (Token s)- , Show e- , ShowErrorComponent e- , Stream s- , Typeable s- , Typeable e- ) => Exception (ParseErrorBundle s e) where+instance+ ( Show s,+ Show (Token s),+ Show e,+ ShowErrorComponent e,+ VisualStream s,+ TraversableStream s,+ Typeable s,+ Typeable e+ ) =>+ Exception (ParseErrorBundle s e)+ where displayException = errorBundlePretty -- | Attach 'SourcePos'es to items in a 'Traversable' container given that@@ -282,14 +306,17 @@ -- Items must be in ascending order with respect to their offsets. -- -- @since 7.0.0--attachSourcePos- :: (Traversable t, Stream s)- => (a -> Int) -- ^ How to project offset from an item (e.g. 'errorOffset')- -> t a -- ^ The collection of items- -> PosState s -- ^ Initial 'PosState'- -> (t (a, SourcePos), PosState s) -- ^ The collection with 'SourcePos'es- -- added and the final 'PosState'+attachSourcePos ::+ (Traversable t, TraversableStream s) =>+ -- | How to project offset from an item (e.g. 'errorOffset')+ (a -> Int) ->+ -- | The collection of items+ t a ->+ -- | Initial 'PosState'+ PosState s ->+ -- | The collection with 'SourcePos'es+ -- added and the final 'PosState'+ (t (a, SourcePos), PosState s) attachSourcePos projectOffset xs = runState (traverse f xs) where f a = do@@ -305,18 +332,14 @@ -- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0- class Ord a => ShowErrorComponent a where- -- | Pretty-print a component of 'ParseError'.- showErrorComponent :: a -> String -- | Length of the error component in characters, used for highlighting of -- parse errors in input string. -- -- @since 7.0.0- errorComponentLen :: a -> Int errorComponentLen _ = 1 @@ -329,43 +352,56 @@ -- rendered 'String' always ends with a newline. -- -- @since 7.0.0--errorBundlePretty- :: forall s e. ( Stream s- , ShowErrorComponent e- )- => ParseErrorBundle s e -- ^ Parse error bundle to display- -> String -- ^ Textual rendition of the bundle+errorBundlePretty ::+ forall s e.+ ( VisualStream s,+ TraversableStream s,+ ShowErrorComponent e+ ) =>+ -- | Parse error bundle to display+ ParseErrorBundle s e ->+ -- | Textual rendition of the bundle+ String errorBundlePretty ParseErrorBundle {..} = let (r, _) = foldl f (id, bundlePosState) bundleErrors- in drop 1 (r "")+ in drop 1 (r "") where- f :: (ShowS, PosState s)- -> ParseError s e- -> (ShowS, PosState s)+ f ::+ (ShowS, PosState s) ->+ ParseError s e ->+ (ShowS, PosState s) f (o, !pst) e = (o . (outChunk ++), pst') where- (sline, pst') = reachOffset (errorOffset e) pst+ (msline, pst') = reachOffset (errorOffset e) pst epos = pstateSourcePos pst' outChunk =- "\n" <> sourcePosPretty epos <> ":\n" <>- padding <> "|\n" <>- lineNumber <> " | " <> sline <> "\n" <>- padding <> "| " <> rpadding <> pointer <> "\n" <>- parseErrorTextPretty e- lineNumber = (show . unPos . sourceLine) epos- padding = replicate (length lineNumber + 1) ' '- rpadding =- if pointerLen > 0- then replicate rpshift ' '- else ""- rpshift = unPos (sourceColumn epos) - 1- pointer = replicate pointerLen '^'- pointerLen =- if rpshift + elen > slineLen- then slineLen - rpshift + 1- else elen- slineLen = length sline+ "\n" <> sourcePosPretty epos <> ":\n"+ <> offendingLine+ <> parseErrorTextPretty e+ offendingLine =+ case msline of+ Nothing -> ""+ Just sline ->+ let rpadding =+ if pointerLen > 0+ then replicate rpshift ' '+ else ""+ pointerLen =+ if rpshift + elen > slineLen+ then slineLen - rpshift + 1+ else elen+ pointer = replicate pointerLen '^'+ lineNumber = (show . unPos . sourceLine) epos+ padding = replicate (length lineNumber + 1) ' '+ rpshift = unPos (sourceColumn epos) - 1+ slineLen = length sline+ in padding <> "|\n" <> lineNumber <> " | " <> sline+ <> "\n"+ <> padding+ <> "| "+ <> rpadding+ <> pointer+ <> "\n" pxy = Proxy :: Proxy s elen = case e of@@ -378,11 +414,12 @@ -- newline. -- -- @since 5.0.0--parseErrorPretty- :: (Stream s, ShowErrorComponent e)- => ParseError s e -- ^ Parse error to render- -> String -- ^ Result of rendering+parseErrorPretty ::+ (VisualStream s, ShowErrorComponent e) =>+ -- | Parse error to render+ ParseError s e ->+ -- | Result of rendering+ String parseErrorPretty e = "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e @@ -391,16 +428,19 @@ -- newline. -- -- @since 5.1.0--parseErrorTextPretty- :: forall s e. (Stream s, ShowErrorComponent e)- => ParseError s e -- ^ Parse error to render- -> String -- ^ Result of rendering+parseErrorTextPretty ::+ forall s e.+ (VisualStream s, ShowErrorComponent e) =>+ -- | Parse error to render+ ParseError s e ->+ -- | Result of rendering+ String parseErrorTextPretty (TrivialError _ us ps) = if isNothing us && E.null ps then "unknown parse error\n"- else messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) <>- messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps)+ else+ messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us)+ <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps) where pxy = Proxy :: Proxy s parseErrorTextPretty (FancyError _ xs) =@@ -412,48 +452,49 @@ -- Helpers -- | Pretty-print an 'ErrorItem'.--showErrorItem :: Stream s => Proxy s -> ErrorItem (Token s) -> String+showErrorItem :: VisualStream s => Proxy s -> ErrorItem (Token s) -> String showErrorItem pxy = \case- Tokens ts -> showTokens pxy ts- Label label -> NE.toList label- EndOfInput -> "end of input"+ Tokens ts -> showTokens pxy ts+ Label label -> NE.toList label+ EndOfInput -> "end of input" -- | Get length of the “pointer” to display under a given 'ErrorItem'.--errorItemLength :: Stream s => Proxy s -> ErrorItem (Token s) -> Int+errorItemLength :: VisualStream s => Proxy s -> ErrorItem (Token s) -> Int errorItemLength pxy = \case Tokens ts -> tokensLength pxy ts- _ -> 1+ _ -> 1 -- | Pretty-print an 'ErrorFancy'.- showErrorFancy :: ShowErrorComponent e => ErrorFancy e -> String showErrorFancy = \case ErrorFail msg -> msg ErrorIndentation ord ref actual ->- "incorrect indentation (got " <> show (unPos actual) <>- ", should be " <> p <> show (unPos ref) <> ")"+ "incorrect indentation (got " <> show (unPos actual)+ <> ", should be "+ <> p+ <> show (unPos ref)+ <> ")" where p = case ord of- LT -> "less than "- EQ -> "equal to "- GT -> "greater than "+ LT -> "less than "+ EQ -> "equal to "+ GT -> "greater than " ErrorCustom a -> showErrorComponent a -- | Get length of the “pointer” to display under a given 'ErrorFancy'.- errorFancyLength :: ShowErrorComponent e => ErrorFancy e -> Int errorFancyLength = \case ErrorCustom a -> errorComponentLen a- _ -> 1+ _ -> 1 -- | Transforms a list of error messages into their textual representation.--messageItemsPretty- :: String -- ^ Prefix to prepend- -> Set String -- ^ Collection of messages- -> String -- ^ Result of rendering+messageItemsPretty ::+ -- | Prefix to prepend+ String ->+ -- | Collection of messages+ Set String ->+ -- | Result of rendering+ String messageItemsPretty prefix ts | E.null ts = "" | otherwise =@@ -461,8 +502,7 @@ -- | Print a pretty list where items are separated with commas and the word -- “or” according to the rules of English punctuation.- orList :: NonEmpty String -> String-orList (x:|[]) = x-orList (x:|[y]) = x <> " or " <> y-orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs+orList (x :| []) = x+orList (x :| [y]) = x <> " or " <> y+orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
Text/Megaparsec/Error.hs-boot view
@@ -1,7 +1,7 @@ {-# LANGUAGE RoleAnnotations #-} module Text.Megaparsec.Error- ( ParseError+ ( ParseError, ) where
Text/Megaparsec/Error/Builder.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Error.Builder -- Copyright : © 2015–present Megaparsec contributors@@ -11,49 +18,43 @@ -- concise. This is primarily useful in test suites and for debugging. -- -- @since 6.0.0--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec.Error.Builder ( -- * Top-level helpers- err- , errFancy+ err,+ errFancy,+ -- * Error components- , utok- , utoks- , ulabel- , ueof- , etok- , etoks- , elabel- , eeof- , fancy+ utok,+ utoks,+ ulabel,+ ueof,+ etok,+ etoks,+ elabel,+ eeof,+ fancy,+ -- * Data types- , ET- , EF )+ ET,+ EF,+ ) where import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Set (Set)+import qualified Data.Set as E import Data.Typeable (Typeable) import GHC.Generics import Text.Megaparsec.Error import Text.Megaparsec.Stream-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E ---------------------------------------------------------------------------- -- Data types -- | Auxiliary type for construction of trivial parse errors.- data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) deriving (Typeable, Generic) @@ -61,25 +62,26 @@ deriving instance Ord (Token s) => Ord (ET s) -deriving instance ( Data s- , Data (Token s)- , Ord (Token s)- ) => Data (ET s)+deriving instance+ ( Data s,+ Data (Token s),+ Ord (Token s)+ ) =>+ Data (ET s) instance Stream s => Semigroup (ET s) where ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1) where- n Nothing Nothing = Nothing+ n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y) instance Stream s => Monoid (ET s) where- mempty = ET Nothing E.empty+ mempty = ET Nothing E.empty mappend = (<>) -- | Auxiliary type for construction of fancy parse errors.- newtype EF e = EF (Set (ErrorFancy e)) deriving (Eq, Ord, Data, Typeable, Generic) @@ -87,7 +89,7 @@ EF xs0 <> EF xs1 = EF (E.union xs0 xs1) instance Ord e => Monoid (EF e) where- mempty = EF E.empty+ mempty = EF E.empty mappend = (<>) ----------------------------------------------------------------------------@@ -96,74 +98,69 @@ -- | Assemble a 'ParseError' from offset and @'ET' t@ value. @'ET' t@ is a -- monoid and can be assembled by combining primitives provided by this -- module, see below.--err- :: Int -- ^ 'ParseError' offset- -> ET s -- ^ Error components- -> ParseError s e -- ^ Resulting 'ParseError'+err ::+ -- | 'ParseError' offset+ Int ->+ -- | Error components+ ET s ->+ -- | Resulting 'ParseError'+ ParseError s e err p (ET us ps) = TrivialError p us ps -- | Like 'err', but constructs a “fancy” 'ParseError'.--errFancy- :: Int -- ^ 'ParseError' offset- -> EF e -- ^ Error components- -> ParseError s e -- ^ Resulting 'ParseError'+errFancy ::+ -- | 'ParseError' offset+ Int ->+ -- | Error components+ EF e ->+ -- | Resulting 'ParseError'+ ParseError s e errFancy p (EF xs) = FancyError p xs ---------------------------------------------------------------------------- -- Error components -- | Construct an “unexpected token” error component.- utok :: Stream s => Token s -> ET s utok = unexp . Tokens . nes -- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'.- utoks :: forall s. Stream s => Tokens s -> ET s utoks = unexp . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “unexpected label” error component. Do not use with empty -- strings (for empty strings it's bottom).- ulabel :: Stream s => String -> ET s ulabel label | label == "" = error "Text.Megaparsec.Error.Builder.ulabel: empty label" | otherwise = unexp . Label . NE.fromList $ label -- | Construct an “unexpected end of input” error component.- ueof :: Stream s => ET s ueof = unexp EndOfInput -- | Construct an “expected token” error component.- etok :: Stream s => Token s -> ET s etok = expe . Tokens . nes -- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'.- etoks :: forall s. Stream s => Tokens s -> ET s etoks = expe . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “expected label” error component. Do not use with empty -- strings.- elabel :: Stream s => String -> ET s elabel label | label == "" = error "Text.Megaparsec.Error.Builder.elabel: empty label" | otherwise = expe . Label . NE.fromList $ label -- | Construct an “expected end of input” error component.- eeof :: Stream s => ET s eeof = expe EndOfInput -- | Construct a custom error component.- fancy :: ErrorFancy e -> EF e fancy = EF . E.singleton @@ -172,28 +169,24 @@ -- | Construct appropriate 'ErrorItem' representation for given token -- stream. Empty string produces 'EndOfInput'.--canonicalizeTokens- :: Stream s- => Proxy s- -> Tokens s- -> ErrorItem (Token s)+canonicalizeTokens ::+ Stream s =>+ Proxy s ->+ Tokens s ->+ ErrorItem (Token s) canonicalizeTokens pxy ts = case NE.nonEmpty (chunkToTokens pxy ts) of Nothing -> EndOfInput Just xs -> Tokens xs -- | Lift an unexpected item into 'ET'.- unexp :: Stream s => ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty -- | Lift an expected item into 'ET'.- expe :: Stream s => ErrorItem (Token s) -> ET s expe p = ET Nothing (E.singleton p) -- | Make a singleton non-empty list from a value.- nes :: a -> NonEmpty a nes x = x :| []
Text/Megaparsec/Internal.hs view
@@ -1,3 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Internal -- Copyright : © 2015–present Megaparsec contributors@@ -13,55 +24,45 @@ -- rely on these unless you really know what you're doing. -- -- @since 6.5.0--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec.Internal ( -- * Data types- Hints (..)- , Reply (..)- , Consumption (..)- , Result (..)- , ParsecT (..)+ Hints (..),+ Reply (..),+ Consumption (..),+ Result (..),+ ParsecT (..),+ -- * Helper functions- , toHints- , withHints- , accHints- , refreshLastHint- , runParsecT- , withParsecT )+ toHints,+ withHints,+ accHints,+ refreshLastHint,+ runParsecT,+ withParsecT,+ ) where import Control.Applicative import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Semigroup import Data.Set (Set)+import qualified Data.Set as E import Data.String (IsString (..)) import Text.Megaparsec.Class import Text.Megaparsec.Error import Text.Megaparsec.State import Text.Megaparsec.Stream-import qualified Control.Monad.Fail as Fail-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E ---------------------------------------------------------------------------- -- Data types@@ -84,7 +85,6 @@ -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input- newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid) @@ -93,40 +93,41 @@ -- parser state at the end of parsing. -- -- See also: 'Consumption', 'Result'.- data Reply e s a = Reply (State s e) Consumption (Result s e a) -- | Whether the input has been consumed or not. -- -- See also: 'Result', 'Reply'.- data Consumption- = Consumed -- ^ Some part of input stream was consumed- | Virgin -- ^ No input was consumed+ = -- | Some part of input stream was consumed+ Consumed+ | -- | No input was consumed+ Virgin -- | 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- = OK a -- ^ Parser succeeded- | Error (ParseError s e) -- ^ Parser failed+ = -- | Parser succeeded+ OK a+ | -- | Parser failed+ Error (ParseError s e) -- | @'ParsecT' e s m a@ is a parser with custom data component of error -- @e@, stream type @s@, underlying monad @m@ and return type @a@.- newtype ParsecT e s m a = ParsecT- { unParser- :: forall b. State s e- -> (a -> State s e -> Hints (Token s) -> m b) -- consumed-OK- -> (ParseError s e -> State s e -> m b) -- consumed-error- -> (a -> State s e -> Hints (Token s) -> m b) -- empty-OK- -> (ParseError s e -> State s e -> m b) -- empty-error- -> m b }+ { unParser ::+ forall b.+ State s e ->+ (a -> State s e -> Hints (Token s) -> m b) -> -- consumed-OK+ (ParseError s e -> State s e -> m b) -> -- consumed-error+ (a -> State s e -> Hints (Token s) -> m b) -> -- empty-OK+ (ParseError s e -> State s e -> m b) -> -- empty-error+ m b+ } -- | @since 5.3.0- instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-}@@ -134,7 +135,6 @@ {-# INLINE sconcat #-} -- | @since 5.3.0- instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where mempty = pure mempty {-# INLINE mempty #-}@@ -144,9 +144,10 @@ {-# INLINE mconcat #-} -- | @since 6.3.0--instance (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e)- => IsString (ParsecT e s m a) where+instance+ (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) =>+ IsString (ParsecT e s m a)+ where fromString s = tokens (==) (fromString s) instance Functor (ParsecT e s m) where@@ -158,54 +159,78 @@ {-# INLINE pMap #-} -- | 'pure' returns a parser that __succeeds__ without consuming input.- instance Stream s => Applicative (ParsecT e s m) where- pure = pPure- (<*>) = pAp+ pure = pPure+ (<*>) = pAp p1 *> p2 = p1 `pBind` const p2- p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }+ p1 <* p2 = do x1 <- p1; void p2; return x1 pPure :: a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} -pAp :: Stream s- => ParsecT e s m (a -> b)- -> ParsecT e s m a- -> ParsecT e s m b+pAp ::+ Stream s =>+ ParsecT e s m (a -> b) ->+ ParsecT e s m a ->+ ParsecT e s m b pAp m k = ParsecT $ \s cok cerr eok eerr ->- let mcok x s' hs = unParser k s' (cok . x) cerr- (accHints hs (cok . x)) (withHints hs cerr)- meok x s' hs = unParser k s' (cok . x) cerr- (accHints hs (eok . x)) (withHints hs eerr)- in unParser m s mcok cerr meok eerr+ let mcok x s' hs =+ unParser+ k+ s'+ (cok . x)+ cerr+ (accHints hs (cok . x))+ (withHints hs cerr)+ meok x s' hs =+ unParser+ k+ s'+ (cok . x)+ cerr+ (accHints hs (eok . x))+ (withHints hs eerr)+ in unParser m s mcok cerr meok eerr {-# INLINE pAp #-} -- | 'empty' is a parser that __fails__ without consuming input.- instance (Ord e, Stream s) => Alternative (ParsecT e s m) where- empty = mzero- (<|>) = mplus+ empty = mzero+ (<|>) = mplus -- | 'return' returns a parser that __succeeds__ without consuming input.- instance Stream s => Monad (ParsecT e s m) where return = pure- (>>=) = pBind+ (>>=) = pBind+ #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif -pBind :: Stream s- => ParsecT e s m a- -> (a -> ParsecT e s m b)- -> ParsecT e s m b+pBind ::+ Stream s =>+ ParsecT e s m a ->+ (a -> ParsecT e s m b) ->+ ParsecT e s m b pBind m k = ParsecT $ \s cok cerr eok eerr ->- let mcok x s' hs = unParser (k x) s' cok cerr- (accHints hs cok) (withHints hs cerr)- meok x s' hs = unParser (k x) s' cok cerr- (accHints hs eok) (withHints hs eerr)- in unParser m s mcok cerr meok eerr+ let mcok x s' hs =+ unParser+ (k x)+ s'+ cok+ cerr+ (accHints hs cok)+ (withHints hs cerr)+ meok x s' hs =+ unParser+ (k x)+ s'+ cok+ cerr+ (accHints hs eok)+ (withHints hs eerr)+ in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} instance Stream s => Fail.MonadFail (ParsecT e s m) where@@ -214,14 +239,14 @@ pFail :: String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ o _ _) _ _ _ eerr -> let d = E.singleton (ErrorFail msg)- in eerr (FancyError o d) s+ in eerr (FancyError o d) s {-# INLINE pFail #-} instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where liftIO = lift . liftIO instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where- ask = lift ask+ ask = lift ask local f p = mkPT $ \s -> local f (runParsecT p s) instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where@@ -232,7 +257,8 @@ callCC f = mkPT $ \s -> callCC $ \c -> runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s- where pack s a = Reply s Virgin (OK a)+ where+ pack s a = Reply s Virgin (OK a) instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError@@ -246,15 +272,14 @@ case consumption of Consumed -> case result of- OK x -> cok x s' mempty+ OK x -> cok x s' mempty Error e -> cerr e s' Virgin -> case result of- OK x -> eok x s' mempty+ OK x -> eok x s' mempty Error e -> eerr 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@@ -264,23 +289,23 @@ eerr (TrivialError o Nothing E.empty) s {-# INLINE pZero #-} -pPlus :: (Ord e, Stream s)- => ParsecT e s m a- -> ParsecT e s m a- -> ParsecT e s m a+pPlus ::+ (Ord e, Stream s) =>+ ParsecT e s m a ->+ ParsecT e s m a ->+ ParsecT e s m a 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 (stateOffset s') err <> hs)+ neok x s' hs = eok x s' (toHints (stateOffset 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+ in unParser n s cok ncerr neok neerr+ in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} -- | From two states, return the one with the greater number of processed -- tokens. If the numbers of processed tokens are equal, prefer the second -- state.- longestMatch :: State s e -> State s e -> State s e longestMatch s1@(State _ o1 _ _) s2@(State _ o2 _ _) = case o1 `compare` o2 of@@ -290,13 +315,11 @@ {-# INLINE longestMatch #-} -- | @since 6.0.0- instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do- let- a = case result of- OK a' -> a'- Error _ -> error "mfix ParsecT"+ let a = case result of+ OK a' -> a'+ Error _ -> error "mfix ParsecT" runParsecT (f a) s instance MonadTrans (ParsecT e s) where@@ -304,25 +327,25 @@ amb >>= \a -> eok a s mempty instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where- parseError = pParseError- label = pLabel- try = pTry- lookAhead = pLookAhead- notFollowedBy = pNotFollowedBy- withRecovery = pWithRecovery- observing = pObserving- eof = pEof- token = pToken- tokens = pTokens- takeWhileP = pTakeWhileP- takeWhile1P = pTakeWhile1P- takeP = pTakeP- getParserState = pGetParserState+ parseError = pParseError+ label = pLabel+ try = pTry+ lookAhead = pLookAhead+ notFollowedBy = pNotFollowedBy+ withRecovery = pWithRecovery+ observing = pObserving+ eof = pEof+ token = pToken+ tokens = pTokens+ takeWhileP = pTakeWhileP+ takeWhile1P = pTakeWhile1P+ takeP = pTakeP+ getParserState = pGetParserState updateParserState = pUpdateParserState -pParseError- :: ParseError s e- -> ParsecT e s m a+pParseError ::+ ParseError s e ->+ ParsecT e s m a pParseError e = ParsecT $ \s _ _ _ eerr -> eerr e s {-# INLINE pParseError #-} @@ -332,26 +355,26 @@ cok' x s' hs = case el of Nothing -> cok x s' (refreshLastHint hs Nothing)- Just _ -> cok x s' hs+ Just _ -> cok x s' hs eok' x s' hs = eok x s' (refreshLastHint hs el)- eerr' err = eerr $+ eerr' err = eerr $ case err of (TrivialError pos us _) -> TrivialError pos us (maybe E.empty E.singleton el) _ -> err- in unParser p s cok' cerr eok' eerr'+ in unParser p s cok' cerr eok' eerr' {-# INLINE pLabel #-} pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr -> let eerr' err _ = eerr err s- in unParser p s cok eerr' eok eerr'+ in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-} pLookAhead :: ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr -> let eok' a _ _ = eok a s mempty- in unParser p s eok' cerr eok' eerr+ in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()@@ -359,101 +382,111 @@ let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input) unexpect u = TrivialError o (pure u) E.empty cok' _ _ _ = eerr (unexpect what) s- cerr' _ _ = eok () s mempty+ cerr' _ _ = eok () s mempty eok' _ _ _ = eerr (unexpect what) s- eerr' _ _ = eok () s mempty- in unParser p s cok' cerr' eok' eerr'+ eerr' _ _ = eok () s mempty+ in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-} -pWithRecovery- :: Stream s- => (ParseError s e -> ParsecT e s m a)- -> ParsecT e s m a- -> ParsecT e s m a+pWithRecovery ::+ Stream s =>+ (ParseError s e -> ParsecT e s m a) ->+ ParsecT e s m a ->+ ParsecT e s m a 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+ rcerr _ _ = cerr err ms reok x s' _ = eok x s' (toHints (stateOffset s') err)- reerr _ _ = cerr err ms- in unParser (r err) ms rcok rcerr reok reerr+ reerr _ _ = cerr err ms+ in unParser (r err) ms rcok rcerr reok reerr meerr err ms = let rcok x s' _ = cok x s' (toHints (stateOffset s') err)- rcerr _ _ = eerr err ms+ rcerr _ _ = eerr err ms reok x s' _ = eok x s' (toHints (stateOffset s') err)- reerr _ _ = eerr err ms- in unParser (r err) ms rcok rcerr reok reerr- in unParser p s cok mcerr eok meerr+ reerr _ _ = eerr err ms+ in unParser (r err) ms rcok rcerr reok reerr+ in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} -pObserving- :: Stream s- => ParsecT e s m a- -> ParsecT e s m (Either (ParseError s e) a)+pObserving ::+ Stream s =>+ ParsecT e s m a ->+ ParsecT e s m (Either (ParseError 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 (stateOffset s') err)- in unParser p s (cok . Right) cerr' (eok . Right) eerr'+ in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} pEof :: forall e s m. Stream s => ParsecT e s m () pEof = ParsecT $ \s@(State input o pst de) _ _ eok eerr -> case take1_ input of- Nothing -> eok () s mempty- Just (x,_) ->+ Nothing -> eok () s mempty+ Just (x, _) -> let us = (pure . Tokens . nes) x ps = E.singleton EndOfInput- in eerr (TrivialError o us ps)- (State input o pst de)+ in eerr+ (TrivialError o us ps)+ (State input o pst de) {-# INLINE pEof #-} -pToken :: forall e s m a. Stream s- => (Token s -> Maybe a)- -> Set (ErrorItem (Token s))- -> ParsecT e s m a+pToken ::+ forall e s m a.+ Stream s =>+ (Token s -> Maybe a) ->+ Set (ErrorItem (Token s)) ->+ ParsecT e s m a pToken test ps = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> case take1_ input of Nothing -> let us = pure EndOfInput- in eerr (TrivialError o us ps) s- Just (c,cs) ->+ in eerr (TrivialError o us ps) s+ Just (c, cs) -> case test c of Nothing -> let us = (Just . Tokens . nes) c- in eerr (TrivialError o us ps)- (State input o pst de)+ in eerr+ (TrivialError o us ps)+ (State input o pst de) Just x -> cok x (State cs (o + 1) pst de) mempty {-# INLINE pToken #-} -pTokens :: forall e s m. Stream s- => (Tokens s -> Tokens s -> Bool)- -> Tokens s- -> ParsecT e s m (Tokens s)+pTokens ::+ forall e s m.+ Stream s =>+ (Tokens s -> Tokens s -> Bool) ->+ Tokens s ->+ ParsecT e s m (Tokens s) pTokens f tts = ParsecT $ \s@(State input o pst de) cok _ eok eerr -> let pxy = Proxy :: Proxy s unexpect pos' u = let us = pure u ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts- in TrivialError pos' us ps+ in TrivialError pos' us ps len = chunkLength pxy tts- in case takeN_ len input of- Nothing ->- eerr (unexpect o EndOfInput) s- Just (tts', input') ->- if f tts tts'- then let st = State input' (o + len) pst de- in if chunkEmpty pxy tts- then eok tts' st mempty- else cok tts' st mempty- else let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts'- in eerr (unexpect o ps) (State input o pst de)+ in case takeN_ len input of+ Nothing ->+ eerr (unexpect o EndOfInput) s+ Just (tts', input') ->+ if f tts tts'+ then+ let st = State input' (o + len) pst de+ in if chunkEmpty pxy tts+ then eok tts' st mempty+ else cok tts' st mempty+ else+ let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts'+ in eerr (unexpect o ps) (State input o pst de) {-# INLINE pTokens #-} -pTakeWhileP :: forall e s m. Stream s- => Maybe String- -> (Token s -> Bool)- -> ParsecT e s m (Tokens s)+pTakeWhileP ::+ forall e s m.+ Stream s =>+ Maybe String ->+ (Token s -> Bool) ->+ ParsecT e s m (Tokens s) pTakeWhileP ml f = ParsecT $ \(State input o pst de) cok _ eok _ -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input@@ -462,15 +495,17 @@ case ml >>= NE.nonEmpty of Nothing -> mempty Just l -> (Hints . pure . E.singleton . Label) l- in if chunkEmpty pxy ts- then eok ts (State input' (o + len) pst de) hs- else cok ts (State input' (o + len) pst de) hs+ in if chunkEmpty pxy ts+ then eok ts (State input' (o + len) pst de) hs+ else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhileP #-} -pTakeWhile1P :: forall e s m. Stream s- => Maybe String- -> (Token s -> Bool)- -> ParsecT e s m (Tokens s)+pTakeWhile1P ::+ forall e s m.+ Stream s =>+ Maybe String ->+ (Token s -> Bool) ->+ ParsecT e s m (Tokens s) pTakeWhile1P ml f = ParsecT $ \(State input o pst de) cok _ _ eerr -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input@@ -480,34 +515,40 @@ case el of Nothing -> mempty Just l -> (Hints . pure . E.singleton) l- in if chunkEmpty pxy ts- then let us = pure $- case take1_ input of- Nothing -> EndOfInput- Just (t,_) -> Tokens (nes t)- ps = maybe E.empty E.singleton el- in eerr (TrivialError o us ps)- (State input o pst de)- else cok ts (State input' (o + len) pst de) hs+ in if chunkEmpty pxy ts+ then+ let us = pure $+ case take1_ input of+ Nothing -> EndOfInput+ Just (t, _) -> Tokens (nes t)+ ps = maybe E.empty E.singleton el+ in eerr+ (TrivialError o us ps)+ (State input o pst de)+ else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhile1P #-} -pTakeP :: forall e s m. Stream s- => Maybe String- -> Int- -> ParsecT e s m (Tokens s)+pTakeP ::+ forall e s m.+ Stream s =>+ Maybe String ->+ Int ->+ ParsecT e s m (Tokens s) pTakeP ml n = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> let pxy = Proxy :: Proxy s el = Label <$> (ml >>= NE.nonEmpty) ps = maybe E.empty E.singleton el- in case takeN_ n input of- Nothing ->- eerr (TrivialError o (pure EndOfInput) ps) s- Just (ts, input') ->- let len = chunkLength pxy ts- in if len /= n- then eerr (TrivialError (o + len) (pure EndOfInput) ps)- (State input o pst de)- else cok ts (State input' (o + len) pst de) mempty+ in case takeN_ n input of+ Nothing ->+ eerr (TrivialError o (pure EndOfInput) ps) s+ Just (ts, input') ->+ let len = chunkLength pxy ts+ in if len /= n+ then+ eerr+ (TrivialError (o + len) (pure EndOfInput) ps)+ (State input o pst de)+ else cok ts (State input' (o + len) pst de) mempty {-# INLINE pTakeP #-} pGetParserState :: ParsecT e s m (State s e)@@ -526,12 +567,13 @@ -- Helper functions -- | Convert 'ParseError' record to 'Hints'.--toHints- :: Stream s- => Int -- ^ Current offset in input stream- -> ParseError s e -- ^ Parse error to convert- -> Hints (Token s)+toHints ::+ Stream s =>+ -- | Current offset in input stream+ Int ->+ -- | Parse error to convert+ ParseError s e ->+ Hints (Token s) toHints streamPos = \case TrivialError errOffset _ ps -> -- NOTE This is important to check here that the error indeed has@@ -546,16 +588,19 @@ -- | @'withHints' hs c@ makes “error” continuation @c@ use given hints @hs@. ----- Note that if resulting continuation gets 'ParseError' that has custom+-- __Note__ that if resulting continuation gets 'ParseError' that has custom -- data in it, hints are ignored.--withHints- :: Stream s- => Hints (Token s) -- ^ Hints to use- -> (ParseError s e -> State s e -> m b) -- ^ Continuation to influence- -> ParseError s e -- ^ First argument of resulting continuation- -> State s e -- ^ Second argument of resulting continuation- -> m b+withHints ::+ Stream s =>+ -- | Hints to use+ Hints (Token s) ->+ -- | Continuation to influence+ (ParseError s e -> State s e -> m b) ->+ -- | First argument of resulting continuation+ ParseError s e ->+ -- | Second argument of resulting continuation+ State s e ->+ m b withHints (Hints ps') c e = case e of TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps')))@@ -564,36 +609,39 @@ -- | @'accHints' hs c@ results in “OK” continuation that will add given -- hints @hs@ to third argument of original continuation @c@.--accHints- :: Hints t -- ^ 'Hints' to add- -> (a -> State s e -> Hints t -> m b) -- ^ An “OK” continuation to alter- -> (a -> State s e -> Hints t -> m b) -- ^ Altered “OK” continuation+accHints ::+ -- | 'Hints' to add+ Hints t ->+ -- | An “OK” continuation to alter+ (a -> State s e -> Hints t -> m b) ->+ -- | Altered “OK” continuation+ (a -> State s e -> Hints t -> m b) accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} -- | Replace the most recent group of hints (if any) with the given -- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in the -- 'label' primitive.- refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t-refreshLastHint (Hints []) _ = Hints []-refreshLastHint (Hints (_:xs)) Nothing = Hints xs-refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs)+refreshLastHint (Hints []) _ = Hints []+refreshLastHint (Hints (_ : xs)) Nothing = Hints xs+refreshLastHint (Hints (_ : xs)) (Just m) = Hints (E.singleton m : xs) {-# INLINE refreshLastHint #-} -- | Low-level unpacking of the 'ParsecT' type.--runParsecT :: Monad m- => ParsecT e s m a -- ^ Parser to run- -> State s e -- ^ Initial state- -> m (Reply e s a)+runParsecT ::+ Monad m =>+ -- | Parser to run+ ParsecT e s m a ->+ -- | Initial state+ State s e ->+ 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' _ = return $ Reply s' Consumed (OK 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' _ = return $ Reply s' Virgin (OK a)+ eerr err s' = return $ Reply s' Virgin (Error err) -- | Transform any custom errors thrown by the parser using the given -- function. Similar in function and purpose to @withExceptT@.@@ -604,26 +652,31 @@ -- collection of delayed parse errors of the outer parser. -- -- @since 7.0.0--withParsecT :: forall e e' s m a. (Monad m, Ord e')- => (e -> e')- -> ParsecT e s m a -- ^ Inner parser- -> ParsecT e' s m a -- ^ Outer parser+withParsecT ::+ forall e e' s m a.+ (Monad m, Ord e') =>+ (e -> e') ->+ -- | Inner parser+ ParsecT e s m a ->+ -- | Outer parser+ ParsecT e' s m a withParsecT f p = ParsecT $ \s cok cerr eok eerr ->- let s' = s- { stateParseErrors = []- }+ let s' =+ s+ { stateParseErrors = []+ } adjustState :: State s e -> State s e'- adjustState st = st- { stateParseErrors =- (mapParseError f <$> stateParseErrors st)- ++ stateParseErrors s- }+ adjustState st =+ st+ { stateParseErrors =+ (mapParseError f <$> stateParseErrors st)+ ++ stateParseErrors s+ } cok' x st hs = cok x (adjustState st) hs cerr' e st = cerr (mapParseError f e) (adjustState st) eok' x st hs = eok x (adjustState st) hs eerr' e st = eerr (mapParseError f e) (adjustState st)- in unParser p s' cok' cerr' eok' eerr'+ in unParser p s' cok' cerr' eok' eerr' where {-# INLINE withParsecT #-}
Text/Megaparsec/Lexer.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors@@ -11,20 +13,18 @@ -- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". -- -- @since 7.0.0--{-# LANGUAGE FlexibleContexts #-}- module Text.Megaparsec.Lexer ( -- * White space- space- , lexeme- , symbol- , symbol' )+ space,+ lexeme,+ symbol,+ symbol',+ ) where +import qualified Data.CaseInsensitive as CI import Text.Megaparsec import Text.Megaparsec.Common-import qualified Data.CaseInsensitive as CI ---------------------------------------------------------------------------- -- White space@@ -53,15 +53,20 @@ -- 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.--space :: MonadParsec e s m- => m () -- ^ A parser for space characters which does not accept empty- -- input (e.g. 'C.space1')- -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')- -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')- -> m ()-space sp line block = skipMany $ choice- [hidden sp, hidden line, hidden block]+space ::+ MonadParsec e s m =>+ -- | A parser for space characters which does not accept empty+ -- input (e.g. 'C.space1')+ m () ->+ -- | A parser for a line comment (e.g. 'skipLineComment')+ m () ->+ -- | A parser for a block comment (e.g. 'skipBlockComment')+ m () ->+ m ()+space sp line block =+ skipMany $+ choice+ [hidden sp, hidden line, hidden block] {-# INLINEABLE space #-} -- | This is a wrapper for lexemes. Typical usage is to supply the first@@ -70,11 +75,13 @@ -- -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal--lexeme :: MonadParsec e s m- => m () -- ^ How to consume white space after lexeme- -> m a -- ^ How to parse actual lexeme- -> m a+lexeme ::+ MonadParsec e s m =>+ -- | How to consume white space after lexeme+ m () ->+ -- | How to parse actual lexeme+ m a ->+ m a lexeme spc p = p <* spc {-# INLINEABLE lexeme #-} @@ -92,20 +99,24 @@ -- > comma = symbol "," -- > colon = symbol ":" -- > dot = symbol "."--symbol :: MonadParsec e s m- => m () -- ^ How to consume white space after lexeme- -> Tokens s -- ^ Symbol to parse- -> m (Tokens s)+symbol ::+ MonadParsec e s m =>+ -- | How to consume white space after lexeme+ m () ->+ -- | Symbol to parse+ Tokens s ->+ m (Tokens s) symbol spc = lexeme spc . string {-# INLINEABLE symbol #-} -- | Case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages.--symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s))- => m () -- ^ How to consume white space after lexeme- -> Tokens s -- ^ Symbol to parse (case-insensitive)- -> m (Tokens s)+symbol' ::+ (MonadParsec e s m, CI.FoldCase (Tokens s)) =>+ -- | How to consume white space after lexeme+ m () ->+ -- | Symbol to parse (case-insensitive)+ Tokens s ->+ m (Tokens s) symbol' spc = lexeme spc . string' {-# INLINEABLE symbol' #-}
Text/Megaparsec/Pos.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ -- | -- Module : Text.Megaparsec.Pos -- Copyright : © 2015–present Megaparsec contributors@@ -12,23 +16,20 @@ -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway.--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Text.Megaparsec.Pos ( -- * Abstract position- Pos- , mkPos- , unPos- , pos1- , defaultTabWidth- , InvalidPosException (..)+ Pos,+ mkPos,+ unPos,+ pos1,+ defaultTabWidth,+ InvalidPosException (..),+ -- * Source position- , SourcePos (..)- , initialPos- , sourcePosPretty )+ SourcePos (..),+ initialPos,+ sourcePosPretty,+ ) where import Control.DeepSeq@@ -46,7 +47,6 @@ -- together. -- -- @since 5.0.0- newtype Pos = Pos Int deriving (Show, Eq, Ord, Data, Typeable, NFData) @@ -54,7 +54,6 @@ -- 'InvalidPosException' when given a non-positive argument. -- -- @since 6.0.0- mkPos :: Int -> Pos mkPos a = if a <= 0@@ -65,7 +64,6 @@ -- | Extract 'Int' from 'Pos'. -- -- @since 6.0.0- unPos :: Pos -> Int unPos (Pos w) = w {-# INLINE unPos #-}@@ -73,7 +71,6 @@ -- | Position with value 1. -- -- @since 6.0.0- pos1 :: Pos pos1 = mkPos 1 @@ -86,7 +83,6 @@ -- > defaultTabWidth = mkPos 8 -- -- @since 5.0.0- defaultTabWidth :: Pos defaultTabWidth = mkPos 8 @@ -98,21 +94,22 @@ readsPrec d = readParen (d > 10) $ \r1 -> do ("Pos", r2) <- lex r1- (x, r3) <- readsPrec 11 r2+ (x, r3) <- readsPrec 11 r2 return (mkPos x, r3) -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number. -- -- @since 5.0.0--newtype InvalidPosException = InvalidPosException Int- -- ^ Contains the actual value that was passed to 'mkPos'+newtype InvalidPosException+ = -- | Contains the actual value that was passed to 'mkPos'+ InvalidPosException Int deriving (Eq, Show, Data, Typeable, Generic) instance Exception InvalidPosException-instance NFData InvalidPosException +instance NFData InvalidPosException+ ---------------------------------------------------------------------------- -- Source position @@ -120,28 +117,29 @@ -- name of the source file, a line number, and a column number. Source line -- and column positions change intensively during parsing, so we need to -- make them strict to avoid memory leaks.- data SourcePos = SourcePos- { sourceName :: FilePath -- ^ Name of source file- , sourceLine :: !Pos -- ^ Line number- , sourceColumn :: !Pos -- ^ Column number- } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)+ { -- | Name of source file+ sourceName :: FilePath,+ -- | Line number+ sourceLine :: !Pos,+ -- | Column number+ sourceColumn :: !Pos+ }+ deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) instance NFData SourcePos -- | Construct initial position (line 1, column 1) given name of source -- file.- initialPos :: FilePath -> SourcePos initialPos n = SourcePos n pos1 pos1 -- | Pretty-print a 'SourcePos'. -- -- @since 5.0.0- sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c)- | null n = showLC+ | null n = showLC | otherwise = n <> ":" <> showLC where showLC = show (unPos l) <> ":" <> show (unPos c)
Text/Megaparsec/State.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.State -- Copyright : © 2015–present Megaparsec contributors@@ -12,58 +18,58 @@ -- Definition of Megaparsec's 'State'. -- -- @since 6.5.0--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}- module Text.Megaparsec.State- ( State (..)- , PosState (..) )+ ( State (..),+ PosState (..),+ ) where import Control.DeepSeq (NFData) import Data.Data (Data) import Data.Typeable (Typeable) import GHC.Generics-import Text.Megaparsec.Pos import {-# SOURCE #-} Text.Megaparsec.Error (ParseError)+import Text.Megaparsec.Pos -- | This is the Megaparsec's state parametrized over stream type @s@ and -- custom error component type @e@.- data State s e = State- { stateInput :: s- -- ^ The rest of input to process- , stateOffset :: {-# UNPACK #-} !Int- -- ^ Number of processed tokens so far+ { -- | The rest of input to process+ stateInput :: s,+ -- | Number of processed tokens so far -- -- @since 7.0.0- , statePosState :: PosState s- -- ^ State that is used for line\/column calculation+ stateOffset :: {-# UNPACK #-} !Int,+ -- | State that is used for line\/column calculation -- -- @since 7.0.0- , stateParseErrors :: [ParseError s e]- -- ^ Collection of “delayed” 'ParseError's in reverse order. This means+ statePosState :: PosState s,+ -- | Collection of “delayed” 'ParseError's in reverse order. This means -- that the last registered error is the first element of the list. -- -- @since 8.0.0- } deriving (Typeable, Generic)+ stateParseErrors :: [ParseError s e]+ }+ deriving (Typeable, Generic) -deriving instance ( Show (ParseError s e)- , Show s- ) => Show (State s e)+deriving instance+ ( Show (ParseError s e),+ Show s+ ) =>+ Show (State s e) -deriving instance ( Eq (ParseError s e)- , Eq s- ) => Eq (State s e)+deriving instance+ ( Eq (ParseError s e),+ Eq s+ ) =>+ Eq (State s e) -deriving instance ( Data e- , Data (ParseError s e)- , Data s- ) => Data (State s e)+deriving instance+ ( Data e,+ Data (ParseError s e),+ Data s+ ) =>+ Data (State s e) instance (NFData s, NFData (ParseError s e)) => NFData (State s e) @@ -71,18 +77,18 @@ -- on demand. -- -- @since 7.0.0- data PosState s = PosState- { pstateInput :: s- -- ^ The rest of input to process- , pstateOffset :: !Int- -- ^ Offset corresponding to beginning of 'pstateInput'- , pstateSourcePos :: !SourcePos- -- ^ Source position corresponding to beginning of 'pstateInput'- , pstateTabWidth :: Pos- -- ^ Tab width to use for column calculation- , pstateLinePrefix :: String- -- ^ Prefix to prepend to offending line- } deriving (Show, Eq, Data, Typeable, Generic)+ { -- | The rest of input to process+ pstateInput :: s,+ -- | Offset corresponding to beginning of 'pstateInput'+ pstateOffset :: !Int,+ -- | Source position corresponding to beginning of 'pstateInput'+ pstateSourcePos :: !SourcePos,+ -- | Tab width to use for column calculation+ pstateTabWidth :: Pos,+ -- | Prefix to prepend to offending line+ pstateLinePrefix :: String+ }+ deriving (Show, Eq, Data, Typeable, Generic) instance NFData s => NFData (PosState s)
Text/Megaparsec/Stream.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Text.Megaparsec.Stream -- Copyright : © 2015–present Megaparsec contributors@@ -13,47 +22,40 @@ -- "Text.Megaparsec" re-exports it anyway. -- -- @since 6.0.0--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}- module Text.Megaparsec.Stream- ( Stream (..) )+ ( Stream (..),+ VisualStream (..),+ TraversableStream (..),+ ) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (chr)-import Data.Foldable (foldl')+import Data.Foldable (foldl', toList) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Proxy+import qualified Data.Sequence as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Data.Word (Word8) import Text.Megaparsec.Pos import Text.Megaparsec.State-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BL8-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL -- | Type class for inputs that can be consumed by the library.-+--+-- __Note__: before the version /9.0.0/ the class included the methods from+-- 'VisualStream' and 'TraversableStream'. class (Ord (Token s), Ord (Tokens s)) => Stream s where- -- | Type of token in the stream.- type Token s :: Type -- | Type of “chunk” of the stream.- type Tokens s :: Type -- | Lift a single token to chunk of the stream. The default@@ -63,26 +65,22 @@ -- -- However for some types of stream there may be a more efficient way to -- lift.-- tokenToChunk :: Proxy s -> Token s -> Tokens s+ tokenToChunk :: Proxy s -> Token s -> Tokens s tokenToChunk pxy = tokensToChunk pxy . pure -- | The first method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > chunkToTokens pxy (tokensToChunk pxy ts) == ts- tokensToChunk :: Proxy s -> [Token s] -> Tokens s -- | The second method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > tokensToChunk pxy (chunkToTokens pxy chunk) == chunk- chunkToTokens :: Proxy s -> Tokens s -> [Token s] -- | Return length of a chunk of the stream.- chunkLength :: Proxy s -> Tokens s -> Int -- | Check if a chunk of the stream is empty. The default implementation@@ -91,13 +89,11 @@ -- > chunkEmpty pxy ts = chunkLength pxy ts <= 0 -- -- However for many streams there may be a more efficient implementation.- chunkEmpty :: Proxy s -> Tokens s -> Bool chunkEmpty pxy ts = chunkLength pxy ts <= 0 -- | Extract a single token form the stream. Return 'Nothing' if the -- stream is empty.- take1_ :: s -> Maybe (Token s, s) -- | @'takeN_' n s@ should try to extract a chunk of length @n@, or if the@@ -113,7 +109,6 @@ -- * In other cases, take chunk of length @n@ (or shorter if the -- stream is not long enough) from the input stream and return the -- chunk along with the rest of the stream.- takeN_ :: Int -> s -> Maybe (Tokens s, s) -- | Extract chunk of the stream taking tokens while the supplied@@ -122,14 +117,110 @@ -- For many types of streams, the method allows for significant -- performance improvements, although it is not strictly necessary from -- conceptual point of view.- takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s) +-- | @since 9.0.0+instance Ord a => Stream [a] where+ type Token [a] = a+ type Tokens [a] = [a]+ tokenToChunk Proxy = pure+ tokensToChunk Proxy = id+ chunkToTokens Proxy = id+ chunkLength Proxy = length+ chunkEmpty Proxy = null+ take1_ [] = Nothing+ take1_ (t : ts) = Just (t, ts)+ takeN_ n s+ | n <= 0 = Just ([], s)+ | null s = Nothing+ | otherwise = Just (splitAt n s)+ takeWhile_ = span++-- | @since 9.0.0+instance Ord a => Stream (S.Seq a) where+ type Token (S.Seq a) = a+ type Tokens (S.Seq a) = S.Seq a+ tokenToChunk Proxy = pure+ tokensToChunk Proxy = S.fromList+ chunkToTokens Proxy = toList+ chunkLength Proxy = length+ chunkEmpty Proxy = null+ take1_ S.Empty = Nothing+ take1_ (t S.:<| ts) = Just (t, ts)+ takeN_ n s+ | n <= 0 = Just (S.empty, s)+ | null s = Nothing+ | otherwise = Just (S.splitAt n s)+ takeWhile_ = S.spanl++instance Stream B.ByteString where+ type Token B.ByteString = Word8+ type Tokens B.ByteString = B.ByteString+ tokenToChunk Proxy = B.singleton+ tokensToChunk Proxy = B.pack+ chunkToTokens Proxy = B.unpack+ chunkLength Proxy = B.length+ chunkEmpty Proxy = B.null+ take1_ = B.uncons+ takeN_ n s+ | n <= 0 = Just (B.empty, s)+ | B.null s = Nothing+ | otherwise = Just (B.splitAt n s)+ takeWhile_ = B.span++instance Stream BL.ByteString where+ type Token BL.ByteString = Word8+ type Tokens BL.ByteString = BL.ByteString+ tokenToChunk Proxy = BL.singleton+ tokensToChunk Proxy = BL.pack+ chunkToTokens Proxy = BL.unpack+ chunkLength Proxy = fromIntegral . BL.length+ chunkEmpty Proxy = BL.null+ take1_ = BL.uncons+ takeN_ n s+ | n <= 0 = Just (BL.empty, s)+ | BL.null s = Nothing+ | otherwise = Just (BL.splitAt (fromIntegral n) s)+ takeWhile_ = BL.span++instance Stream T.Text where+ type Token T.Text = Char+ type Tokens T.Text = T.Text+ tokenToChunk Proxy = T.singleton+ tokensToChunk Proxy = T.pack+ chunkToTokens Proxy = T.unpack+ chunkLength Proxy = T.length+ chunkEmpty Proxy = T.null+ take1_ = T.uncons+ takeN_ n s+ | n <= 0 = Just (T.empty, s)+ | T.null s = Nothing+ | otherwise = Just (T.splitAt n s)+ takeWhile_ = T.span++instance Stream TL.Text where+ type Token TL.Text = Char+ type Tokens TL.Text = TL.Text+ tokenToChunk Proxy = TL.singleton+ tokensToChunk Proxy = TL.pack+ chunkToTokens Proxy = TL.unpack+ chunkLength Proxy = fromIntegral . TL.length+ chunkEmpty Proxy = TL.null+ take1_ = TL.uncons+ takeN_ n s+ | n <= 0 = Just (TL.empty, s)+ | TL.null s = Nothing+ | otherwise = Just (TL.splitAt (fromIntegral n) s)+ takeWhile_ = TL.span++-- | Type class for inputs that can also be used for debugging.+--+-- @since 9.0.0+class Stream s => VisualStream s where -- | Pretty-print non-empty stream of tokens. This function is also used -- to print single tokens (represented as singleton lists). -- -- @since 7.0.0- showTokens :: Proxy s -> NonEmpty (Token s) -> String -- | Return the number of characters that a non-empty stream of tokens@@ -137,17 +228,39 @@ -- exactly 1 character. -- -- @since 8.0.0- tokensLength :: Proxy s -> NonEmpty (Token s) -> Int tokensLength Proxy = NE.length +instance VisualStream String where+ showTokens Proxy = stringPretty++instance VisualStream B.ByteString where+ showTokens Proxy = stringPretty . fmap (chr . fromIntegral)++instance VisualStream BL.ByteString where+ showTokens Proxy = stringPretty . fmap (chr . fromIntegral)++instance VisualStream T.Text where+ showTokens Proxy = stringPretty++instance VisualStream TL.Text where+ showTokens Proxy = stringPretty++-- | Type class for inputs that can also be used for error reporting.+--+-- @since 9.0.0+class Stream s => TraversableStream s where+ {-# MINIMAL reachOffset | reachOffsetNoLine #-}+ -- | Given an offset @o@ and initial 'PosState', adjust the state in such -- a way that it starts at the offset. -- -- Return two values (in order): --- -- * 'String' representing the line on which the given offset @o@ is- -- located. The line should satisfy a number of conditions that are+ -- * 'Maybe' 'String' representing the line on which the given offset+ -- @o@ is located. It can be omitted (i.e. 'Nothing'); in that case+ -- error reporting functions will not show offending lines. If+ -- returned, the line should satisfy a number of conditions that are -- described below. -- * The updated 'PosState' which can be in turn used to locate -- another offset @o'@ given that @o' >= o@.@@ -166,14 +279,18 @@ -- 'PosState'. -- -- __Note__: type signature of the function was changed in the version- -- /8.0.0/.+ -- /9.0.0/. -- -- @since 7.0.0-- reachOffset- :: Int -- ^ Offset to reach- -> PosState s -- ^ Initial 'PosState' to use- -> (String, PosState s) -- ^ See the description of the function+ reachOffset ::+ -- | Offset to reach+ Int ->+ -- | Initial 'PosState' to use+ PosState s ->+ -- | See the description of the function+ (Maybe String, PosState s)+ reachOffset o pst =+ (Nothing, reachOffsetNoLine o pst) -- | A version of 'reachOffset' that may be faster because it doesn't need -- to fetch the line at which the given offset in located.@@ -187,114 +304,45 @@ -- /8.0.0/. -- -- @since 7.0.0-- reachOffsetNoLine- :: Int -- ^ Offset to reach- -> PosState s -- ^ Initial 'PosState' to use- -> PosState s -- ^ Reached source position and updated state+ reachOffsetNoLine ::+ -- | Offset to reach+ Int ->+ -- | Initial 'PosState' to use+ PosState s ->+ -- | Reached source position and updated state+ PosState s reachOffsetNoLine o pst = snd (reachOffset o pst) -instance Stream String where- type Token String = Char- type Tokens String = String- tokenToChunk Proxy = pure- tokensToChunk Proxy = id- chunkToTokens Proxy = id- chunkLength Proxy = length- chunkEmpty Proxy = null- take1_ [] = Nothing- take1_ (t:ts) = Just (t, ts)- takeN_ n s- | n <= 0 = Just ("", s)- | null s = Nothing- | otherwise = Just (splitAt n s)- takeWhile_ = span- showTokens Proxy = stringPretty+instance TraversableStream String where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst =- reachOffset' splitAt foldl' id id ('\n','\t') o pst+ reachOffset' splitAt foldl' id id ('\n', '\t') o pst reachOffsetNoLine o pst = reachOffsetNoLine' splitAt foldl' ('\n', '\t') o pst -instance Stream B.ByteString where- type Token B.ByteString = Word8- type Tokens B.ByteString = B.ByteString- tokenToChunk Proxy = B.singleton- tokensToChunk Proxy = B.pack- chunkToTokens Proxy = B.unpack- chunkLength Proxy = B.length- chunkEmpty Proxy = B.null- take1_ = B.uncons- takeN_ n s- | n <= 0 = Just (B.empty, s)- | B.null s = Nothing- | otherwise = Just (B.splitAt n s)- takeWhile_ = B.span- showTokens Proxy = stringPretty . fmap (chr . fromIntegral)+instance TraversableStream B.ByteString where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst = reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) o pst reachOffsetNoLine o pst = reachOffsetNoLine' B.splitAt B.foldl' (10, 9) o pst -instance Stream BL.ByteString where- type Token BL.ByteString = Word8- type Tokens BL.ByteString = BL.ByteString- tokenToChunk Proxy = BL.singleton- tokensToChunk Proxy = BL.pack- chunkToTokens Proxy = BL.unpack- chunkLength Proxy = fromIntegral . BL.length- chunkEmpty Proxy = BL.null- take1_ = BL.uncons- takeN_ n s- | n <= 0 = Just (BL.empty, s)- | BL.null s = Nothing- | otherwise = Just (BL.splitAt (fromIntegral n) s)- takeWhile_ = BL.span- showTokens Proxy = stringPretty . fmap (chr . fromIntegral)+instance TraversableStream BL.ByteString where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst = reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) o pst reachOffsetNoLine o pst = reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) o pst -instance Stream T.Text where- type Token T.Text = Char- type Tokens T.Text = T.Text- tokenToChunk Proxy = T.singleton- tokensToChunk Proxy = T.pack- chunkToTokens Proxy = T.unpack- chunkLength Proxy = T.length- chunkEmpty Proxy = T.null- take1_ = T.uncons- takeN_ n s- | n <= 0 = Just (T.empty, s)- | T.null s = Nothing- | otherwise = Just (T.splitAt n s)- takeWhile_ = T.span- showTokens Proxy = stringPretty+instance TraversableStream T.Text where -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). reachOffset o pst = reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') o pst reachOffsetNoLine o pst = reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') o pst -instance Stream TL.Text where- type Token TL.Text = Char- type Tokens TL.Text = TL.Text- tokenToChunk Proxy = TL.singleton- tokensToChunk Proxy = TL.pack- chunkToTokens Proxy = TL.unpack- chunkLength Proxy = fromIntegral . TL.length- chunkEmpty Proxy = TL.null- take1_ = TL.uncons- takeN_ n s- | n <= 0 = Just (TL.empty, s)- | TL.null s = Nothing- | otherwise = Just (TL.splitAt (fromIntegral n) s)- takeWhile_ = TL.span- showTokens Proxy = stringPretty+instance TraversableStream TL.Text where -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). reachOffset o pst = reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') o pst@@ -306,161 +354,162 @@ -- | An internal helper state type combining a difference 'String' and an -- unboxed 'SourcePos'.- data St = St SourcePos ShowS -- | A helper definition to facilitate defining 'reachOffset' for various -- stream types.-+reachOffset' ::+ forall s.+ Stream s =>+ -- | How to split input stream at given offset+ (Int -> s -> (Tokens s, s)) ->+ -- | How to fold over input stream+ (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->+ -- | How to convert chunk of input stream into a 'String'+ (Tokens s -> String) ->+ -- | How to convert a token into a 'Char'+ (Token s -> Char) ->+ -- | Newline token and tab token+ (Token s, Token s) ->+ -- | Offset to reach+ Int ->+ -- | Initial 'PosState' to use+ PosState s ->+ -- | Line at which 'SourcePos' is located, updated 'PosState'+ (Maybe String, PosState s) reachOffset'- :: forall s. Stream s- => (Int -> s -> (Tokens s, s))- -- ^ How to split input stream at given offset- -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)- -- ^ How to fold over input stream- -> (Tokens s -> String)- -- ^ How to convert chunk of input stream into a 'String'- -> (Token s -> Char)- -- ^ How to convert a token into a 'Char'- -> (Token s, Token s)- -- ^ Newline token and tab token- -> Int- -- ^ Offset to reach- -> PosState s- -- ^ Initial 'PosState' to use- -> (String, PosState s)- -- ^ Line at which 'SourcePos' is located, updated 'PosState'-reachOffset' splitAt'- foldl''- fromToks- fromTok- (newlineTok, tabTok)- o- PosState {..} =- ( case expandTab pstateTabWidth- . addPrefix- . f- . fromToks- . fst- $ takeWhile_ (/= newlineTok) post of- "" -> "<empty line>"- xs -> xs- , PosState- { pstateInput = post- , pstateOffset = max pstateOffset o- , pstateSourcePos = spos- , pstateTabWidth = pstateTabWidth- , pstateLinePrefix =- if sameLine- -- NOTE We don't use difference lists here because it's- -- desirable for 'PosState' to be an instance of 'Eq' and- -- 'Show'. So we just do appending here. Fortunately several- -- parse errors on the same line should be relatively rare.- then pstateLinePrefix ++ f ""- else f ""- }- )- where- addPrefix xs =- if sameLine- then pstateLinePrefix ++ xs- else xs- sameLine = sourceLine spos == sourceLine pstateSourcePos- (pre, post) = splitAt' (o - pstateOffset) pstateInput- St spos f = foldl'' go (St pstateSourcePos id) pre- go (St apos g) ch =- let SourcePos n l c = apos- 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 :))+ splitAt'+ foldl''+ fromToks+ fromTok+ (newlineTok, tabTok)+ o+ PosState {..} =+ ( Just $ case expandTab pstateTabWidth+ . addPrefix+ . f+ . fromToks+ . fst+ $ takeWhile_ (/= newlineTok) post of+ "" -> "<empty line>"+ xs -> xs,+ PosState+ { pstateInput = post,+ pstateOffset = max pstateOffset o,+ pstateSourcePos = spos,+ pstateTabWidth = pstateTabWidth,+ pstateLinePrefix =+ if sameLine+ then -- NOTE We don't use difference lists here because it's+ -- desirable for 'PosState' to be an instance of 'Eq' and+ -- 'Show'. So we just do appending here. Fortunately several+ -- parse errors on the same line should be relatively rare.+ pstateLinePrefix ++ f ""+ else f ""+ }+ )+ where+ addPrefix xs =+ if sameLine+ then pstateLinePrefix ++ xs+ else xs+ sameLine = sourceLine spos == sourceLine pstateSourcePos+ (pre, post) = splitAt' (o - pstateOffset) pstateInput+ St spos f = foldl'' go (St pstateSourcePos id) pre+ go (St apos g) ch =+ let SourcePos n l c = apos+ 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 :)) {-# INLINE reachOffset' #-} -- | Like 'reachOffset'' but for 'reachOffsetNoLine'.-+reachOffsetNoLine' ::+ forall s.+ Stream s =>+ -- | How to split input stream at given offset+ (Int -> s -> (Tokens s, s)) ->+ -- | How to fold over input stream+ (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->+ -- | Newline token and tab token+ (Token s, Token s) ->+ -- | Offset to reach+ Int ->+ -- | Initial 'PosState' to use+ PosState s ->+ -- | Updated 'PosState'+ PosState s reachOffsetNoLine'- :: forall s. Stream s- => (Int -> s -> (Tokens s, s))- -- ^ How to split input stream at given offset- -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)- -- ^ How to fold over input stream- -> (Token s, Token s)- -- ^ Newline token and tab token- -> Int- -- ^ Offset to reach- -> PosState s- -- ^ Initial 'PosState' to use- -> PosState s- -- ^ Updated 'PosState'-reachOffsetNoLine' splitAt'- foldl''- (newlineTok, tabTok)- o- PosState {..} =- ( PosState- { pstateInput = post- , pstateOffset = max pstateOffset o- , pstateSourcePos = spos- , pstateTabWidth = pstateTabWidth- , pstateLinePrefix = pstateLinePrefix- }- )- where- spos = foldl'' go pstateSourcePos pre- (pre, post) = splitAt' (o - pstateOffset) pstateInput- go (SourcePos n l c) ch =- 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)+ splitAt'+ foldl''+ (newlineTok, tabTok)+ o+ PosState {..} =+ ( PosState+ { pstateInput = post,+ pstateOffset = max pstateOffset o,+ pstateSourcePos = spos,+ pstateTabWidth = pstateTabWidth,+ pstateLinePrefix = pstateLinePrefix+ }+ )+ where+ spos = foldl'' go pstateSourcePos pre+ (pre, post) = splitAt' (o - pstateOffset) pstateInput+ go (SourcePos n l c) ch =+ 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) {-# INLINE reachOffsetNoLine' #-} -- | Like 'BL.splitAt' but accepts the index as an 'Int'.- splitAtBL :: Int -> BL.ByteString -> (BL.ByteString, BL.ByteString) splitAtBL n = BL.splitAt (fromIntegral n) {-# INLINE splitAtBL #-} -- | Like 'TL.splitAt' but accepts the index as an 'Int'.- splitAtTL :: Int -> TL.Text -> (TL.Text, TL.Text) splitAtTL n = TL.splitAt (fromIntegral n) {-# INLINE splitAtTL #-} -- | @stringPretty s@ returns pretty representation of string @s@. This is -- used when printing string tokens in error messages.- stringPretty :: NonEmpty Char -> String-stringPretty (x:|[]) = charPretty x-stringPretty ('\r':|"\n") = "crlf newline"-stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\""+stringPretty (x :| []) = charPretty x+stringPretty ('\r' :| "\n") = "crlf newline"+stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\"" where f ch = case charPretty' ch of- Nothing -> [ch]+ Nothing -> [ch] Just pretty -> "<" <> pretty <> ">" -- | @charPretty ch@ returns user-friendly string representation of given -- character @ch@, suitable for using in error messages.- charPretty :: Char -> String charPretty ' ' = "space" charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch) -- | If the given character has a pretty representation, return that, -- otherwise 'Nothing'. This is an internal helper.- charPretty' :: Char -> Maybe String charPretty' = \case '\NUL' -> Just "null"@@ -471,14 +520,14 @@ '\ENQ' -> Just "enquiry" '\ACK' -> Just "acknowledge" '\BEL' -> Just "bell"- '\BS' -> Just "backspace"- '\t' -> Just "tab"- '\n' -> Just "newline"- '\v' -> Just "vertical tab"- '\f' -> Just "form feed"- '\r' -> Just "carriage return"- '\SO' -> Just "shift out"- '\SI' -> Just "shift in"+ '\BS' -> Just "backspace"+ '\t' -> Just "tab"+ '\n' -> Just "newline"+ '\v' -> Just "vertical tab"+ '\f' -> Just "form feed"+ '\r' -> Just "carriage return"+ '\SO' -> Just "shift out"+ '\SI' -> Just "shift in" '\DLE' -> Just "data link escape" '\DC1' -> Just "device control one" '\DC2' -> Just "device control two"@@ -488,27 +537,26 @@ '\SYN' -> Just "synchronous idle" '\ETB' -> Just "end of transmission block" '\CAN' -> Just "cancel"- '\EM' -> Just "end of medium"+ '\EM' -> Just "end of medium" '\SUB' -> Just "substitute" '\ESC' -> Just "escape"- '\FS' -> Just "file separator"- '\GS' -> Just "group separator"- '\RS' -> Just "record separator"- '\US' -> Just "unit separator"+ '\FS' -> Just "file separator"+ '\GS' -> Just "group separator"+ '\RS' -> Just "record separator"+ '\US' -> Just "unit separator" '\DEL' -> Just "delete" '\160' -> Just "non-breaking space"- _ -> Nothing+ _ -> Nothing -- | Replace tab characters with given number of spaces.--expandTab- :: Pos- -> String- -> String+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'+ 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'
bench/memory/Main.hs view
@@ -1,51 +1,50 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Control.Monad import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as E import Data.Text (Text)+import qualified Data.Text as T import Data.Void import Text.Megaparsec import Text.Megaparsec.Char-import Weigh-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E-import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L+import Weigh #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>)) #endif -- | The type of parser that consumes 'String's.- type Parser = Parsec Void Text main :: IO () main = mainWith $ do setColumns [Case, Allocated, GCs, Max]- bparser "string" manyAs (string . fst)- bparser "string'" manyAs (string' . fst)- bparser "many" manyAs (const $ many (char 'a'))- bparser "some" manyAs (const $ some (char 'a'))- bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd)- bparser "count" manyAs (\(_,n) -> count n (char 'a'))- bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a'))- bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b'))- bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b'))+ bparser "string" manyAs (string . fst)+ bparser "string'" manyAs (string' . fst)+ bparser "many" manyAs (const $ many (char 'a'))+ bparser "some" manyAs (const $ some (char 'a'))+ bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd)+ bparser "count" manyAs (\(_, n) -> count n (char 'a'))+ bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a'))+ bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b'))+ bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))- bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b'))- bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b'))- bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b'))+ bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b'))+ bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b'))+ bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) bparser "skipMany" manyAs (const $ skipMany (char 'a')) bparser "skipSome" manyAs (const $ skipSome (char 'a'))- bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a'))+ bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')) bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a'))@@ -60,7 +59,7 @@ bbundle "2 errors" 1000 [1, 1000] bbundle "4 errors" 1000 [1, 500, 1000]- bbundle "100 errors" 1000 [10,20..1000]+ bbundle "100 errors" 1000 [10, 20 .. 1000] breachOffset 0 1000 breachOffset 0 2000@@ -73,123 +72,134 @@ breachOffsetNoLine 1000 1000 -- | Perform a series of measurements with the same parser.--bparser :: NFData a- => String -- ^ Name of the benchmark group- -> (Int -> Text) -- ^ How to construct input- -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input- -> Weigh ()+bparser ::+ NFData a =>+ -- | Name of the benchmark group+ String ->+ -- | How to construct input+ (Int -> Text) ->+ -- | The parser receiving its future input+ ((Text, Int) -> Parser a) ->+ Weigh () bparser name f p = forM_ stdSeries $ \i -> do- let arg = (f i,i)- p' (s,n) = parse (p (s,n)) "" s+ let arg = (f i, i)+ p' (s, n) = parse (p (s, n)) "" s func (name ++ "-" ++ show i) p' arg -- | Bench the 'errorBundlePretty' function.--bbundle- :: String -- ^ Name of the benchmark- -> Int -- ^ Number of lines in input stream- -> [Int] -- ^ Lines with parse errors- -> Weigh ()+bbundle ::+ -- | Name of the benchmark+ String ->+ -- | Number of lines in input stream+ Int ->+ -- | Lines with parse errors+ [Int] ->+ Weigh () bbundle name totalLines sps = do let s = take (totalLines * 80) (cycle as) as = replicate 79 'a' ++ "\n"- f l = TrivialError- (20 + l * 80)- (Just $ Tokens ('a' :| ""))- (E.singleton $ Tokens ('b' :| ""))+ f l =+ TrivialError+ (20 + l * 80)+ (Just $ Tokens ('a' :| ""))+ (E.singleton $ Tokens ('b' :| "")) bundle :: ParseErrorBundle String Void- bundle = ParseErrorBundle- { bundleErrors = f <$> NE.fromList sps- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""+ bundle =+ ParseErrorBundle+ { bundleErrors = f <$> NE.fromList sps,+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } }- }- func ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)- errorBundlePretty- bundle+ func+ ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+ errorBundlePretty+ bundle -- | Bench the 'reachOffset' function.--breachOffset- :: Int -- ^ Starting offset in 'PosState'- -> Int -- ^ Offset to reach- -> Weigh ()-breachOffset o0 o1 = func- ("reachOffset-" ++ show o0 ++ "-" ++ show o1)- f- (o0 * 80, o1 * 80)+breachOffset ::+ -- | Starting offset in 'PosState'+ Int ->+ -- | Offset to reach+ Int ->+ Weigh ()+breachOffset o0 o1 =+ func+ ("reachOffset-" ++ show o0 ++ "-" ++ show o1)+ f+ (o0 * 80, o1 * 80) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) =- snd $ reachOffset targetOffset PosState- { pstateInput = manyAs (targetOffset - startOffset)- , pstateOffset = startOffset- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }+ snd $+ reachOffset+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -- | Bench the 'reachOffsetNoLine' function.--breachOffsetNoLine- :: Int -- ^ Starting offset in 'PosState'- -> Int -- ^ Offset to reach- -> Weigh ()-breachOffsetNoLine o0 o1 = func- ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)- f- (o0 * 80, o1 * 80)+breachOffsetNoLine ::+ -- | Starting offset in 'PosState'+ Int ->+ -- | Offset to reach+ Int ->+ Weigh ()+breachOffsetNoLine o0 o1 =+ func+ ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)+ f+ (o0 * 80, o1 * 80) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) =- reachOffsetNoLine targetOffset PosState- { pstateInput = manyAs (targetOffset - startOffset)- , pstateOffset = startOffset- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }+ reachOffsetNoLine+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -- | The series of sizes to try as part of 'bparser'.- stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]+stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters.- manyAs :: Int -> Text manyAs n = T.replicate n "a" -- | Like 'manyAs', but interspersed with \'b\'s.- manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end.- manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'.- manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'.- manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument.- mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100))
bench/speed/Main.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Criterion.Main import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as E import Data.Text (Text)+import qualified Data.Text as T import Data.Void import Text.Megaparsec import Text.Megaparsec.Char-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E-import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L #if !MIN_VERSION_base(4,13,0)@@ -21,171 +21,178 @@ #endif -- | The type of parser that consumes 'String's.- type Parser = Parsec Void Text main :: IO ()-main = defaultMain- [ bparser "string" manyAs (string . fst)- , bparser "string'" manyAs (string' . fst)- , bparser "many" manyAs (const $ many (char 'a'))- , bparser "some" manyAs (const $ some (char 'a'))- , bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd)- , bparser "count" manyAs (\(_,n) -> count n (char 'a'))- , bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a'))- , bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b'))- , bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b'))- , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))- , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))- , bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b'))- , bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b'))- , bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b'))- , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))- , bparser "skipMany" manyAs (const $ skipMany (char 'a'))- , bparser "skipSome" manyAs (const $ skipSome (char 'a'))- , bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a'))- , bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b'))- , bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b'))- , bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a'))- , bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a'))- , bparser "decimal" mkInt (const (L.decimal :: Parser Integer))- , bparser "octal" mkInt (const (L.octal :: Parser Integer))- , bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer))- , bparser "scientific" mkInt (const L.scientific)-- , bgroup "" [bbundle "single error" n [n] | n <- stdSeries]-- , bbundle "2 errors" 1000 [1, 1000]- , bbundle "4 errors" 1000 [1, 500, 1000]- , bbundle "100 errors" 1000 [10,20..1000]-- , breachOffset 0 1000- , breachOffset 0 2000- , breachOffset 0 4000- , breachOffset 1000 1000-- , breachOffsetNoLine 0 1000- , breachOffsetNoLine 0 2000- , breachOffsetNoLine 0 4000- , breachOffsetNoLine 1000 1000-- ]+main =+ defaultMain+ [ bparser "string" manyAs (string . fst),+ bparser "string'" manyAs (string' . fst),+ bparser "many" manyAs (const $ many (char 'a')),+ bparser "some" manyAs (const $ some (char 'a')),+ bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd),+ bparser "count" manyAs (\(_, n) -> count n (char 'a')),+ bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a')),+ bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')),+ bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')),+ bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')),+ bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')),+ bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')),+ bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')),+ bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')),+ bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')),+ bparser "skipMany" manyAs (const $ skipMany (char 'a')),+ bparser "skipSome" manyAs (const $ skipSome (char 'a')),+ bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')),+ bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')),+ bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')),+ bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')),+ bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a')),+ bparser "decimal" mkInt (const (L.decimal :: Parser Integer)),+ bparser "octal" mkInt (const (L.octal :: Parser Integer)),+ bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)),+ bparser "scientific" mkInt (const L.scientific),+ bgroup "" [bbundle "single error" n [n] | n <- stdSeries],+ bbundle "2 errors" 1000 [1, 1000],+ bbundle "4 errors" 1000 [1, 500, 1000],+ bbundle "100 errors" 1000 [10, 20 .. 1000],+ breachOffset 0 1000,+ breachOffset 0 2000,+ breachOffset 0 4000,+ breachOffset 1000 1000,+ breachOffsetNoLine 0 1000,+ breachOffsetNoLine 0 2000,+ breachOffsetNoLine 0 4000,+ breachOffsetNoLine 1000 1000+ ] -- | Perform a series to measurements with the same parser.--bparser :: NFData a- => String -- ^ Name of the benchmark group- -> (Int -> Text) -- ^ How to construct input- -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input- -> Benchmark -- ^ The benchmark+bparser ::+ NFData a =>+ -- | Name of the benchmark group+ String ->+ -- | How to construct input+ (Int -> Text) ->+ -- | The parser receiving its future input+ ((Text, Int) -> Parser a) ->+ -- | The benchmark+ Benchmark bparser name f p = bgroup name (bs <$> stdSeries) where bs n = env (return (f n, n)) (bench (show n) . nf p')- p' (s,n) = parse (p (s,n)) "" s+ p' (s, n) = parse (p (s, n)) "" s -- | Bench the 'errorBundlePretty' function.--bbundle- :: String -- ^ Name of the benchmark- -> Int -- ^ Number of lines in input stream- -> [Int] -- ^ Lines with parse errors- -> Benchmark+bbundle ::+ -- | Name of the benchmark+ String ->+ -- | Number of lines in input stream+ Int ->+ -- | Lines with parse errors+ [Int] ->+ Benchmark bbundle name totalLines sps = let s = take (totalLines * 80) (cycle as) as = replicate 79 'a' ++ "\n"- f l = TrivialError- (20 + l * 80)- (Just $ Tokens ('a' :| ""))- (E.singleton $ Tokens ('b' :| ""))+ f l =+ TrivialError+ (20 + l * 80)+ (Just $ Tokens ('a' :| ""))+ (E.singleton $ Tokens ('b' :| "")) bundle :: ParseErrorBundle String Void- bundle = ParseErrorBundle- { bundleErrors = f <$> NE.fromList sps- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""+ bundle =+ ParseErrorBundle+ { bundleErrors = f <$> NE.fromList sps,+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } }- }- in bench ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)- (nf errorBundlePretty bundle)+ in bench+ ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+ (nf errorBundlePretty bundle) -- | Bench the 'reachOffset' function.--breachOffset- :: Int -- ^ Starting offset in 'PosState'- -> Int -- ^ Offset to reach- -> Benchmark-breachOffset o0 o1 = bench- ("reachOffset-" ++ show o0 ++ "-" ++ show o1)- (nf f (o0 * 80, o1 * 80))+breachOffset ::+ -- | Starting offset in 'PosState'+ Int ->+ -- | Offset to reach+ Int ->+ Benchmark+breachOffset o0 o1 =+ bench+ ("reachOffset-" ++ show o0 ++ "-" ++ show o1)+ (nf f (o0 * 80, o1 * 80)) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) =- snd $ reachOffset targetOffset PosState- { pstateInput = manyAs (targetOffset - startOffset)- , pstateOffset = startOffset- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }+ snd $+ reachOffset+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -- | Bench the 'reachOffsetNoLine' function.--breachOffsetNoLine- :: Int -- ^ Starting offset in 'PosState'- -> Int -- ^ Offset to reach- -> Benchmark-breachOffsetNoLine o0 o1 = bench- ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)- (nf f (o0 * 80, o1 * 80))+breachOffsetNoLine ::+ -- | Starting offset in 'PosState'+ Int ->+ -- | Offset to reach+ Int ->+ Benchmark+breachOffsetNoLine o0 o1 =+ bench+ ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)+ (nf f (o0 * 80, o1 * 80)) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) =- reachOffsetNoLine targetOffset PosState- { pstateInput = manyAs (targetOffset - startOffset)- , pstateOffset = startOffset- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }+ reachOffsetNoLine+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -- | The series of sizes to try as part of 'bparser'.- stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]+stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters.- manyAs :: Int -> Text manyAs n = T.replicate n "a" -- | Like 'manyAs', but interspersed with \'b\'s.- manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end.- manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'.- manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'.- manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument.- mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100))
megaparsec.cabal view
@@ -1,102 +1,116 @@-name: megaparsec-version: 8.0.0-cabal-version: 1.18-tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1-license: BSD2-license-file: LICENSE.md-author: Megaparsec contributors,- Paolo Martini <paolo@nemail.it>,- Daan Leijen <daan@microsoft.com>+cabal-version: 1.18+name: megaparsec+version: 9.0.0+license: BSD2+license-file: LICENSE.md+maintainer: Mark Karpov <markkarpov92@gmail.com>+author:+ Megaparsec contributors,+ Paolo Martini <paolo@nemail.it>,+ Daan Leijen <daan@microsoft.com> -maintainer: Mark Karpov <markkarpov92@gmail.com>-homepage: https://github.com/mrkkrp/megaparsec-bug-reports: https://github.com/mrkkrp/megaparsec/issues-category: Parsing-synopsis: Monadic parser combinators-build-type: Simple+tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1+homepage: https://github.com/mrkkrp/megaparsec+bug-reports: https://github.com/mrkkrp/megaparsec/issues+synopsis: Monadic parser combinators description:-- This is an industrial-strength monadic parser combinator library.- Megaparsec is a feature-rich package that tries to find a nice balance- between speed, flexibility, and quality of parse errors.+ This is an industrial-strength monadic parser combinator library.+ Megaparsec is a feature-rich package that tries to find a nice balance+ between speed, flexibility, and quality of parse errors. -extra-doc-files: CHANGELOG.md- , README.md+category: Parsing+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md source-repository head- type: git- location: https://github.com/mrkkrp/megaparsec.git+ type: git+ location: https://github.com/mrkkrp/megaparsec.git flag dev- description: Turn on development settings.- manual: True- default: False+ description: Turn on development settings.+ default: False+ manual: True library- build-depends: base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , case-insensitive >= 1.2 && < 1.3- , containers >= 0.5 && < 0.7- , deepseq >= 1.3 && < 1.5- , mtl >= 2.2.2 && < 3.0- , parser-combinators >= 1.0 && < 2.0- , scientific >= 0.3.1 && < 0.4- , text >= 0.2 && < 1.3- , transformers >= 0.4 && < 0.6- exposed-modules: Text.Megaparsec- , Text.Megaparsec.Byte- , Text.Megaparsec.Byte.Lexer- , Text.Megaparsec.Char- , Text.Megaparsec.Char.Lexer- , Text.Megaparsec.Debug- , Text.Megaparsec.Error- , Text.Megaparsec.Error.Builder- , Text.Megaparsec.Internal- , Text.Megaparsec.Pos- , Text.Megaparsec.Stream- other-modules: Text.Megaparsec.Class- , Text.Megaparsec.Common- , Text.Megaparsec.Lexer- , Text.Megaparsec.State- if flag(dev)- ghc-options: -O0 -Wall -Werror- else- ghc-options: -O2 -Wall- if flag(dev)- ghc-options: -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances- default-language: Haskell2010+ exposed-modules:+ Text.Megaparsec+ Text.Megaparsec.Byte+ Text.Megaparsec.Byte.Lexer+ Text.Megaparsec.Char+ Text.Megaparsec.Char.Lexer+ Text.Megaparsec.Debug+ Text.Megaparsec.Error+ Text.Megaparsec.Error.Builder+ Text.Megaparsec.Internal+ Text.Megaparsec.Pos+ Text.Megaparsec.Stream + other-modules:+ Text.Megaparsec.Class+ Text.Megaparsec.Common+ Text.Megaparsec.Lexer+ Text.Megaparsec.State++ default-language: Haskell2010+ build-depends:+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ case-insensitive >=1.2 && <1.3,+ containers >=0.5 && <0.7,+ deepseq >=1.3 && <1.5,+ mtl >=2.2.2 && <3.0,+ parser-combinators >=1.0 && <2.0,+ scientific >=0.3.1 && <0.4,+ text >=0.2 && <1.3,+ transformers >=0.4 && <0.6++ if flag(dev)+ ghc-options: -O0 -Wall -Werror++ else+ ghc-options: -O2 -Wall++ if flag(dev)+ ghc-options:+ -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Wnoncanonical-monad-instances -Wno-missing-home-modules+ benchmark bench-speed- main-is: Main.hs- hs-source-dirs: bench/speed- type: exitcode-stdio-1.0- build-depends: base >= 4.11 && < 5.0- , containers >= 0.5 && < 0.7- , criterion >= 0.6.2.1 && < 1.6- , deepseq >= 1.3 && < 1.5- , megaparsec- , text >= 0.2 && < 1.3- if flag(dev)- ghc-options: -O2 -Wall -Werror- else- ghc-options: -O2 -Wall- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/speed+ default-language: Haskell2010+ build-depends:+ base >=4.12 && <5.0,+ containers >=0.5 && <0.7,+ criterion >=0.6.2.1 && <1.6,+ deepseq >=1.3 && <1.5,+ megaparsec -any,+ text >=0.2 && <1.3 + if flag(dev)+ ghc-options: -O2 -Wall -Werror++ else+ ghc-options: -O2 -Wall+ benchmark bench-memory- main-is: Main.hs- hs-source-dirs: bench/memory- type: exitcode-stdio-1.0- build-depends: base >= 4.11 && < 5.0- , containers >= 0.5 && < 0.7- , deepseq >= 1.3 && < 1.5- , megaparsec- , text >= 0.2 && < 1.3- , weigh >= 0.0.4- if flag(dev)- ghc-options: -O2 -Wall -Werror- else- ghc-options: -O2 -Wall- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/memory+ default-language: Haskell2010+ build-depends:+ base >=4.12 && <5.0,+ containers >=0.5 && <0.7,+ deepseq >=1.3 && <1.5,+ megaparsec -any,+ text >=0.2 && <1.3,+ weigh >=0.0.4++ if flag(dev)+ ghc-options: -O2 -Wall -Werror++ else+ ghc-options: -O2 -Wall