megaparsec 8.0.0 → 9.8.1
raw patch · 25 files changed
Files
- CHANGELOG.md +147/−6
- README.md +24/−23
- Setup.hs +0/−2
- Text/Megaparsec.hs +227/−218
- Text/Megaparsec/Byte.hs +79/−69
- Text/Megaparsec/Byte/Binary.hs +192/−0
- Text/Megaparsec/Byte/Lexer.hs +139/−113
- Text/Megaparsec/Char.hs +106/−103
- Text/Megaparsec/Char/Lexer.hs +235/−188
- Text/Megaparsec/Class.hs +255/−231
- Text/Megaparsec/Common.hs +13/−13
- Text/Megaparsec/Debug.hs +272/−78
- Text/Megaparsec/Error.hs +330/−222
- Text/Megaparsec/Error.hs-boot +2/−1
- Text/Megaparsec/Error/Builder.hs +77/−84
- Text/Megaparsec/Internal.hs +425/−287
- Text/Megaparsec/Internal.hs-boot +10/−0
- Text/Megaparsec/Lexer.hs +54/−41
- Text/Megaparsec/Pos.hs +33/−35
- Text/Megaparsec/State.hs +91/−46
- Text/Megaparsec/Stream.hs +542/−277
- Text/Megaparsec/Unicode.hs +223/−0
- bench/memory/Main.hs +130/−98
- bench/speed/Main.hs +154/−124
- megaparsec.cabal +114/−89
CHANGELOG.md view
@@ -1,5 +1,146 @@-## Megaparec 8.0.0+*Megaparsec follows [SemVer](https://semver.org/).* +## Megaparsec 9.8.1++* Fixed the regression introduced by the fix for the [issue+ 572](https://github.com/mrkkrp/megaparsec/issues/572) which caused the+ position marker `^` to be missing in certain cases.+* This release officially supports GHC 9.6. This is the oldest GHC version+ we support at this time.++## Megaparsec 9.8.0++* Fixed the associativity of the `(<|>)` operator. [Issue+ 412](https://github.com/mrkkrp/megaparsec/issues/412).+* Fixed the loss of precision in `decimal`, `binary`, `octal`, and+ `hexadecimal` functions in `Text.Megaparsec.Byte.Lexer` and+ `Text.Megaparsec.Char.Lexer` when they are used to parse floating point+ numbers. [Issue 479](https://github.com/mrkkrp/megaparsec/issues/479).+* Fixed handling of zero-width characters in error messages. To that end,+ added `isZeroWidthChar` function in `Text.Megaparsec.Unicode`. [Issue+ 572](https://github.com/mrkkrp/megaparsec/issues/572).++## Megaparsec 9.7.1++* Typo fixes and compatibility with `QuickCheck >= 2.17` for+ `megaparsec-tests`.++## Megaparsec 9.7.0++* Implemented correct handling of wide Unicode characters in error messages.+ To that end, a new module `Text.Megaparsec.Unicode` was introduced. [Issue+ 370](https://github.com/mrkkrp/megaparsec/issues/370).+* Inlined `Applicative` operators `(<*)` and `(*>)`. [PR+ 566](https://github.com/mrkkrp/megaparsec/pull/566).+* `many` and `some` of the `Alternative` instance of `ParsecT` are now more+ efficient, since they use the monadic implementations under the hood.+ [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567).+* Added `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR+ 573](https://github.com/mrkkrp/megaparsec/pull/573).++## Megaparsec 9.6.1++* Exposed `Text.Megaparsec.State`, so that the new functions (`initialState`+ and `initialPosState`) can be actually imported from it. [PR+ 549](https://github.com/mrkkrp/megaparsec/pull/549).++## Megaparsec 9.6.0++* Added the functions `initialState` and `initialPosState` to+ `Text.Megaparsec.State`. [Issue+ 449](https://github.com/mrkkrp/megaparsec/issues/449).++## Megaparsec 9.5.0++* Dropped a number of redundant constraints here and there. [PR+ 523](https://github.com/mrkkrp/megaparsec/pull/523).++* Added a `MonadWriter` instance for `ParsecT`. [PR+ 534](https://github.com/mrkkrp/megaparsec/pull/534).++## Megaparsec 9.4.1++* Removed `Monad m` constraints in several places where they were introduced+ in 9.4.0. [Issue 532](https://github.com/mrkkrp/megaparsec/issues/532).++## Megaparsec 9.4.0++* `dbg` now prints hints among other debug information. [PR+ 530](https://github.com/mrkkrp/megaparsec/pull/530).++* Hints are no longer lost in certain methods of MTL instances for+ `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528).++* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be+ used to construct “new primitives” with arbitrary behavior at the expense+ of having to dive into Megaparsec's internals. [PR+ 514](https://github.com/mrkkrp/megaparsec/pull/514).++## Megaparsec 9.3.1++* Fixed a bug related to processing of tabs when error messages are+ rendered. [Issue 524](https://github.com/mrkkrp/megaparsec/issues/524).++## Megaparsec 9.3.0++* Now `label` can override more than one group of hints in the parser it+ wraps. [Issue 482](https://github.com/mrkkrp/megaparsec/issues/482).++* `takeP n` now returns the empty chunk of the input stream when `n` is+ negative, similar to when `n == 0`. [Issue+ 497](https://github.com/mrkkrp/megaparsec/issues/497).++* Added the `MonadParsecDbg` type class in `Text.Megaparsec.Debug`. The type+ class allows us to use `dbg` in MTL monad transformers. [Issue+ 488](https://github.com/mrkkrp/megaparsec/issues/488).++* Introduced the `ShareInput` and `NoShareInput` newtype wrappers in+ `Text.Megaparsec.Stream` in order to allow the user to choose how the+ input should be sliced and shared during the parsing. [Issue+ 492](https://github.com/mrkkrp/megaparsec/issues/492).++## Megaparsec 9.2.2++* Fixed a space leak in the implementations of the `reachOffset` and+ `reachOffsetNoLine` methods of `TraversableStream`. [Issue+ 486](https://github.com/mrkkrp/megaparsec/issues/486).++## Megaparsec 9.2.1++* Builds with `mtl-2.3` and `transformers-0.6`.++## Megaparsec 9.2.0++* Added parsers for binary representations (little/big endian) of numbers in+ `Text.Megaparsec.Byte.Binary`.++## Megaparsec 9.1.0++* Added `dbg'` in `Text.Megaparsec.Debug` for debugging parsers that have+ unshowable return values.++* Documentation improvements.++## Megaparsec 9.0.1++* Added [Safe+ Haskell](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html)+ support.++## 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 +449,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 +542,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 +964,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)+[](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml) * [Features](#features) * [Core features](#core-features)@@ -88,16 +88,16 @@ ### Error messages * Megaparsec has typed error messages and the ability to signal custom parse- errors that better suit user's domain of interest.+ errors that better suit the user's domain of interest. -* Since version 8, location of parse errors can independent of current+* Since version 8, the location of parse errors can independent of current offset in the input stream. It is useful when you want a parse error to point to a particular position after performing some checks. -* Instead of single parse error Megaparsec produces so-called+* Instead of a single parse error Megaparsec produces so-called `ParseErrorBundle` data type that helps to manage multi-error messages and- pretty-print them easily and efficiently. Since version 8, reporting- multiple parse errors at once has become much easier.+ pretty-print them. Since version 8, reporting multiple parse errors at+ once has become easier. ### External lexers @@ -139,8 +139,7 @@ You can find the most complete Megaparsec tutorial [here][the-tutorial]. It should provide sufficient guidance to help you start with your parsing-tasks. The site also has instructions and tips for Parsec users who decide-to migrate to Megaparsec.+tasks. ## Performance @@ -160,7 +159,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@@ -185,12 +184,12 @@ matters more than quality of error messages. * *Megaparsec* is good for parsing of source code or other human-readable- texts. It has better error messages and it's implemented as monad+ texts. It has better error messages and it's implemented as a monad transformer. -So, if you work with something human-readable where size of input data is-moderate, just go with Megaparsec, otherwise Attoparsec may be a better-choice.+So, if you work with something human-readable where the size of input data+is moderate, it makes sense to go with Megaparsec, otherwise Attoparsec may+be a better choice. ### Megaparsec vs Parsec @@ -209,18 +208,18 @@ * Better support for Unicode parsing in [`Text.Megaparsec.Char`][tm-char]. * Megaparsec has more powerful combinators and can parse languages where- indentation matters out-of-the-box.+ indentation matters. * Better documentation. * Megaparsec can recover from parse errors “on the fly” and continue parsing. -* Megaparsec allows us to conditionally process parse errors *inside your- parser* before parsing is finished. In particular, it's possible to define- regions in which parse errors, should they happen, will get a “context- tag”, e.g. we could build a context stack like “in function definition- foo”, “in expression x”, etc.+* Megaparsec allows us to conditionally process parse errors inside a+ running parser. In particular, it's possible to define regions in which+ parse errors, should they happen, will get a “context tag”, e.g. we could+ build a context stack like “in function definition foo”, “in expression+ x”, etc. * Megaparsec is faster and supports efficient operations `tokens`, `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec.@@ -236,13 +235,12 @@ use: * Complicated, doesn't have any tutorials available, and documentation- doesn't help at all.+ doesn't help much. * Trifecta can parse `String` and `ByteString` natively, but not `Text`. * Depends on `lens`, which is a very heavy dependency. If you're not into- `lens` and would like to keep your code “vanilla”, you may not like the- API.+ `lens`, you may not like the API. [Idris][idris] has switched from Trifecta to Megaparsec which allowed it to [have better error messages and fewer dependencies][idris-testimony].@@ -283,6 +281,9 @@ library for easily using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in Megaparsec.+* [`parser-combinators`](https://hackage.haskell.org/package/parser-combinators)—provides permutation and expression parsers [previously bundled with Megaparsec](https://markkarpov.com/post/megaparsec-7.html#parsercombinators-grows-megaparsec-shrinks).+* [`faster-megaparsec`](https://hackage.haskell.org/package/faster-megaparsec)—speeds up parsing+ by trying a simple `MonadParsec` instance and falls back to `ParsecT` to report errors. ## Prominent projects that use Megaparsec @@ -330,7 +331,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
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Text/Megaparsec.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec -- Copyright : © 2015–present Megaparsec contributors@@ -11,11 +20,10 @@ -- -- 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+-- almost everything that you may need, we advise to import -- "Text.Megaparsec.Char" if you plan to work with a stream of 'Char' tokens -- or "Text.Megaparsec.Byte" if you intend to parse binary data. --@@ -44,92 +52,94 @@ -- 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 -- -- Note that we re-export monadic combinators from -- "Control.Monad.Combinators" because these are more efficient than--- 'Applicative'-based ones. Thus 'many' and 'some' may clash with the+-- 'Applicative'-based ones (†). Thus 'many' and 'some' may clash with the -- functions from "Control.Applicative". You need to hide the functions like -- this: -- -- > import Control.Applicative hiding (many, some) --+-- † As of Megaparsec 9.7.0 'Control.Applicative.many' and+-- 'Control.Applicative.some' are as efficient as their monadic+-- counterparts.+-- -- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you -- wish that combinators like 'some' return 'NonEmpty' lists. The module -- lives in the @parser-combinators@ package (you need at least version@@ -150,7 +160,6 @@ -- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' -- monad transformer.- type Parsec e s = ParsecT e s Identity ----------------------------------------------------------------------------@@ -169,12 +178,16 @@ -- > 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' is the same as 'runParser'.+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@@ -184,28 +197,30 @@ -- -- The function is supposed to be useful for lightweight parsing, where -- 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.-+-- should be consumed. For example, it can be used for parsing of a single+-- number according to a specification of its format. 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+-- | The expression @'parseTest' p input@ applies the parser @p@ on 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,25 +229,30 @@ -- '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' is the same as 'parse'.+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--- accepts and returns parser state. This allows to specify arbitrary--- textual position at the beginning of parsing, for example. This is the--- most general way to run a parser over the 'Identity' monad.+-- accepts and returns the parser state. This allows us e.g. to specify+-- arbitrary textual position at the beginning of parsing. This is the 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 +260,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,42 +276,29 @@ -- 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 ->+ OK _ x -> case NE.nonEmpty (stateParseErrors s') of Nothing -> (s', Right x) Just de -> (s', Left (toBundle de)) Error e -> (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 = ""- }- , stateParseErrors = []- }- ---------------------------------------------------------------------------- -- Signaling parse errors @@ -302,12 +312,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 +328,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,8 +342,7 @@ -- 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 :: (MonadParsec e s m) => ErrorItem (Token s) -> m a unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-} @@ -342,8 +352,7 @@ -- > customFailure = fancyFailure . Set.singleton . ErrorCustom -- -- @since 6.3.0--customFailure :: MonadParsec e s m => e -> m a+customFailure :: (MonadParsec e s m) => e -> m a customFailure = fancyFailure . E.singleton . ErrorCustom {-# INLINE customFailure #-} @@ -351,23 +360,24 @@ -- wrapper. This applies to both normal and delayed 'ParseError's. -- -- As a side-effect of the implementation the inner computation will start--- with empty collection of delayed errors and they will be updated and+-- with an empty collection of delayed errors and they will be updated and -- “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@@ -376,26 +386,26 @@ -- | Register a 'ParseError' for later reporting. This action does not end -- parsing and has no effect except for adding the given 'ParseError' to the -- collection of “delayed” 'ParseError's which will be taken into--- consideration at the end of parsing. Only if this collection is empty--- parser will succeed. This is the main way to report several parse errors+-- consideration at the end of parsing. Only if this collection is empty will+-- the parser succeed. This is the main way to report several parse errors -- at once. -- -- @since 8.0.0--registerParseError :: MonadParsec e s m => ParseError s e -> m ()+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 +414,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 +435,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@@ -441,13 +452,18 @@ -- > digitChar = satisfy isDigit <?> "digit" -- > oneOf cs = satisfy (`elem` cs) --+-- __Performance note__: when you need to parse a single token, it is often+-- a good idea to use 'satisfy' with the right predicate function instead of+-- creating a complex parser using the combinators.+-- -- 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,8 +477,7 @@ -- See also: 'satisfy', 'anySingleBut'. -- -- @since 7.0.0--anySingle :: MonadParsec e s m => m (Token s)+anySingle :: (MonadParsec e s m) => m (Token s) anySingle = satisfy (const True) {-# INLINE anySingle #-} @@ -474,10 +489,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,14 +515,15 @@ -- > quoteSlow = oneOf "'\"" -- -- @since 7.0.0--oneOf :: (Foldable f, MonadParsec e s m)- => f (Token s) -- ^ Collection of matching tokens- -> m (Token s)-oneOf cs = satisfy (`elem` cs)+oneOf ::+ (Foldable f, MonadParsec e s m) =>+ -- | Collection of matching tokens+ f (Token s) ->+ m (Token s)+oneOf cs = satisfy (\x -> elem x cs) {-# INLINE oneOf #-} --- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token+-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token is -- /not/ in the supplied list of tokens @ts@. Returns the parsed character. -- Note that this parser cannot automatically generate the “expected” -- component of error message, so usually you should label it manually with@@ -520,11 +537,12 @@ -- 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 cs = satisfy (`notElem` cs)+noneOf ::+ (Foldable f, MonadParsec e s m) =>+ -- | Collection of tokens we should not match+ f (Token s) ->+ m (Token s)+noneOf cs = satisfy (\x -> notElem x cs) {-# INLINE noneOf #-} -- | @'chunk' chk@ only matches the chunk @chk@.@@ -535,18 +553,18 @@ -- '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+(<?>) :: (MonadParsec e s m) => m a -> String -> m a (<?>) = flip label {-# INLINE (<?>) #-} @@ -556,12 +574,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 :: (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,8 +594,7 @@ -- > takeRest = takeWhileP Nothing (const True) -- -- @since 6.0.0--takeRest :: MonadParsec e s m => m (Tokens s)+takeRest :: (MonadParsec e s m) => m (Tokens s) takeRest = takeWhileP Nothing (const True) {-# INLINE takeRest #-} @@ -587,8 +603,7 @@ -- > atEnd = option False (True <$ hidden eof) -- -- @since 6.0.0--atEnd :: MonadParsec e s m => m Bool+atEnd :: (MonadParsec e s m) => m Bool atEnd = option False (True <$ hidden eof) {-# INLINE atEnd #-} @@ -596,14 +611,12 @@ -- Parser state combinators -- | Return the current input.--getInput :: MonadParsec e s m => m s+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 :: (MonadParsec e s m) => s -> m () setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) {-# INLINE setInput #-} @@ -616,12 +629,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,8 +642,7 @@ -- See also: 'setOffset'. -- -- @since 7.0.0--getOffset :: MonadParsec e s m => m Int+getOffset :: (MonadParsec e s m) => m Int getOffset = stateOffset <$> getParserState {-# INLINE getOffset #-} @@ -640,8 +651,7 @@ -- See also: 'getOffset'. -- -- @since 7.0.0--setOffset :: MonadParsec e s m => Int -> m ()+setOffset :: (MonadParsec e s m) => Int -> m () setOffset o = updateParserState $ \(State s _ pst de) -> State s o pst de {-# INLINE setOffset #-}@@ -649,7 +659,6 @@ -- | @'setParserState' st@ sets the parser state to @st@. -- -- See also: 'getParserState', 'updateParserState'.--setParserState :: MonadParsec e s m => State s e -> m ()+setParserState :: (MonadParsec e s m) => State s e -> m () setParserState st = updateParserState (const st) {-# INLINE setParserState #-}
Text/Megaparsec/Byte.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module : Text.Megaparsec.Byte -- Copyright : © 2015–present Megaparsec contributors@@ -10,41 +15,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 +62,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 +89,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 +164,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 +171,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 +179,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 +195,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 +208,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 +255,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/Binary.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Text.Megaparsec.Byte.Binary+-- Copyright : © 2021–present Megaparsec contributors+-- License : FreeBSD+--+-- Maintainer : Mark Karpov <markkarpov92@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Binary-format number parsers.+--+-- @since 9.2.0+module Text.Megaparsec.Byte.Binary+ ( -- * Generic parsers+ BinaryChunk (..),+ anyLE,+ anyBE,++ -- * Parsing unsigned values+ word8,+ word16le,+ word16be,+ word32le,+ word32be,+ word64le,+ word64be,++ -- * Parsing signed values+ int8,+ int16le,+ int16be,+ int32le,+ int32be,+ int64le,+ int64be,+ )+where++import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Int+import Data.Word+import Text.Megaparsec++-- | Data types that can be converted to little- or big- endian numbers.+class BinaryChunk chunk where+ convertChunkBE :: (Bits a, Num a) => chunk -> a+ convertChunkLE :: (Bits a, Num a) => chunk -> a++instance BinaryChunk B.ByteString where+ convertChunkBE = B.foldl' go 0+ where+ go acc byte = (acc `unsafeShiftL` 8) .|. fromIntegral byte+ convertChunkLE = B.foldl' go 0+ where+ go acc byte = (acc .|. fromIntegral byte) `rotateR` 8++instance BinaryChunk BL.ByteString where+ convertChunkBE = BL.foldl' go 0+ where+ go acc byte = (acc `unsafeShiftL` 8) .|. fromIntegral byte+ convertChunkLE = BL.foldl' go 0+ where+ go acc byte = (acc .|. fromIntegral byte) `rotateR` 8++----------------------------------------------------------------------------+-- Generic parsers++-- | Parse a little-endian number.+--+-- You may wish to call this with a visible type application:+--+-- > number <- anyLE (Just "little-endian 32 bit word") @Word32+anyLE ::+ forall a e s m.+ (MonadParsec e s m, FiniteBits a, Num a, BinaryChunk (Tokens s)) =>+ -- | Label, if any+ Maybe String ->+ m a+anyLE mlabel = convertChunkLE <$> takeP mlabel (finiteByteSize @a)+{-# INLINE anyLE #-}++-- | Parse a big-endian number.+--+-- You may wish to call this with a visible type application:+--+-- > number <- anyBE (Just "big-endian 32 bit word") @Word32+anyBE ::+ forall a e s m.+ (MonadParsec e s m, FiniteBits a, Num a, BinaryChunk (Tokens s)) =>+ -- | Label, if any+ Maybe String ->+ m a+anyBE mlabel = convertChunkBE <$> takeP mlabel (finiteByteSize @a)+{-# INLINE anyBE #-}++--------------------------------------------------------------------------------+-- Parsing unsigned values++-- | Parse a 'Word8'.+word8 :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word8+word8 = anyBE (Just "8 bit word")+{-# INLINE word8 #-}++-- | Parse a little-endian 'Word16'.+word16le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word16+word16le = anyLE (Just "little-endian 16 bit word")+{-# INLINE word16le #-}++-- | Parse a big-endian 'Word16'.+word16be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word16+word16be = anyBE (Just "big-endian 16 bit word")+{-# INLINE word16be #-}++-- | Parse a little-endian 'Word32'.+word32le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word32+word32le = anyLE (Just "little-endian 32 bit word")+{-# INLINE word32le #-}++-- | Parse a big-endian 'Word32'.+word32be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word32+word32be = anyBE (Just "big-endian 32 bit word")+{-# INLINE word32be #-}++-- | Parse a little-endian 'Word64'.+word64le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word64+word64le = anyLE (Just "little-endian 64 word")+{-# INLINE word64le #-}++-- | Parse a big-endian 'Word64'.+word64be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word64+word64be = anyBE (Just "big-endian 64 word")+{-# INLINE word64be #-}++----------------------------------------------------------------------------+-- Parsing signed values++-- | Parse a 'Int8'.+int8 :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int8+int8 = anyBE (Just "8 bit int")+{-# INLINE int8 #-}++-- | Parse a little-endian 'Int16'.+int16le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int16+int16le = anyLE (Just "little-endian 16 bit int")+{-# INLINE int16le #-}++-- | Parse a big-endian 'Int16'.+int16be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int16+int16be = anyBE (Just "big-endian 16 bit int")+{-# INLINE int16be #-}++-- | Parse a little-endian 'Int32'.+int32le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int32+int32le = anyLE (Just "little-endian 32 bit int")+{-# INLINE int32le #-}++-- | Parse a big-endian 'Int32'.+int32be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int32+int32be = anyBE (Just "big-endian 32 bit int")+{-# INLINE int32be #-}++-- | Parse a little-endian 'Int64'.+int64le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int64+int64le = anyLE (Just "little-endian 64 int")+{-# INLINE int64le #-}++-- | Parse a big-endian 'Int64'.+int64be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int64+int64be = anyBE (Just "big-endian 64 int")+{-# INLINE int64be #-}++--------------------------------------------------------------------------------+-- Helpers++-- | Return the number of bytes in the argument.+--+-- Performs ceiling division, so byte-unaligned types (bitsize not a+-- multiple of 8) should work, but further usage is not tested.+finiteByteSize :: forall a. (FiniteBits a) => Int+finiteByteSize = finiteBitSize @a undefined `ceilDiv` 8+ where+ ceilDiv x y = (x + y - 1) `div` y+{-# INLINE finiteByteSize #-}
Text/Megaparsec/Byte/Lexer.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module : Text.Megaparsec.Byte.Lexer -- Copyright : © 2015–present Megaparsec contributors@@ -13,62 +18,63 @@ -- 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 import Data.Functor (void)-import Data.List (foldl')+import qualified Data.List 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 --- | Given comment prefix this function returns a parser that skips line+-- | Given a comment prefix this function returns a parser that skips line -- 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) =>+ -- | 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 +85,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@@ -94,50 +102,55 @@ ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of--- integer literals described in the Haskell report.+-- | Parse an integer in the decimal representation according to the format+-- of 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+--+-- __Warning__: this function does not perform range checks.+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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w = a * 10 + fromIntegral (w - 48) {-# INLINE decimal_ #-} --- | Parse an integer in binary representation. Binary number is expected to--- be a non-empty sequence of zeroes “0” and ones “1”.+-- | Parse an integer in the binary representation. The binary number is+-- expected to be a non-empty sequence of zeroes “0” and ones “1”. -- -- You could of course parse some prefix before the actual number: -- -- > binary = char 48 >> char' 98 >> L.binary --+-- __Warning__: this function does not perform range checks.+-- -- @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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a w = a * 2 + fromIntegral (w - 48) isBinDigit w = w == 48 || w == 49 {-# INLINEABLE binary #-} --- | Parse an integer in octal representation. Representation of octal+-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing@@ -146,20 +159,23 @@ -- 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"+--+-- __Warning__: this function does not perform range checks.+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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a w = a * 8 + fromIntegral (w - 48) isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of+-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before@@ -168,23 +184,26 @@ -- 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"+--+-- __Warning__: this function does not perform range checks.+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 = fromInteger . Data.List.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 +216,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 +235,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 = Data.List.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 +284,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)@@ -273,8 +300,7 @@ ---------------------------------------------------------------------------- -- Helpers --- | A fast predicate to check if given 'Word8' is a digit in ASCII.-+-- | A fast predicate to check if the 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,10 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module : Text.Megaparsec.Char -- Copyright : © 2015–present Megaparsec contributors@@ -10,47 +17,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 +71,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 +98,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 9.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 +143,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 +163,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 +181,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 +188,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 +288,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 +301,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,10 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module : Text.Megaparsec.Char.Lexer -- Copyright : © 2015–present Megaparsec contributors@@ -26,77 +33,78 @@ -- > 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 Data.List (foldl')+import qualified Data.Char as Char+import qualified Data.List 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 --- | Given comment prefix this function returns a parser that skips line+-- | Given a comment prefix this function returns a parser that skips line -- 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) =>+ -- | 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 +115,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 +139,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 +151,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 +175,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 +198,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,38 +212,38 @@ -- '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”--- token. Reference token can influence parsing, see 'IndentOpt' for more--- information.+-- | Parse a “reference” token and a number of other tokens that have a+-- greater (but the same for all of them) level of indentation than that of+-- the “reference” token. The reference token can influence parsing, see+-- 'IndentOpt' for more information. ----- Tokens /must not/ consume newlines after them. On the other hand, the--- first argument of this function /must/ consume newlines among other white--- space characters.+-- __Note__: the first argument of this function /must/ consume newlines+-- among other white 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 +256,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 +309,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 +339,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,57 +346,61 @@ 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 #-} ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of--- integer literals described in the Haskell report.+-- | Parse an integer in the decimal representation according to the format+-- of integer literals described in the Haskell report. -- -- 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.+--+-- __Warning__: this function does not perform range checks. 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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 10 + fromIntegral (Char.digitToInt c) {-# INLINE decimal_ #-} --- | Parse an integer in binary representation. Binary number is expected to--- be a non-empty sequence of zeroes “0” and ones “1”.+-- | Parse an integer in binary representation. The binary number is+-- expected to be a non-empty sequence of zeroes “0” and ones “1”. -- -- You could of course parse some prefix before the actual number: -- -- > binary = char '0' >> char' 'b' >> L.binary --+-- __Warning__: this function does not perform range checks.+-- -- @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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ step a c = a * 2 + fromIntegral (Char.digitToInt c) isBinDigit x = x == '0' || x == '1' {-# INLINEABLE binary #-} --- | Parse an integer in octal representation. Representation of octal+-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing@@ -378,21 +410,24 @@ -- -- > 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"+--+-- __Warning__: this function does not perform range checks.+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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 8 + fromIntegral (Char.digitToInt c) {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of+-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before@@ -402,17 +437,20 @@ -- -- > 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"+--+-- __Warning__: this function does not perform range checks.+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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 16 + fromIntegral (Char.digitToInt c) {-# INLINEABLE hexadecimal #-} @@ -428,14 +466,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,46 +485,52 @@ -- 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 = Data.List.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_ {-# INLINE exponent_ #-} --- | @'signed' space p@ parser parses an optional sign character (“+” or--- “-”), then if there is a sign it consumes optional white space (using--- @space@ parser), then it runs parser @p@ which should return a number.--- Sign of the number is changed according to the previously parsed sign+-- | @'signed' space p@ parses an optional sign character (“+” or “-”), then+-- if there is a sign it consumes optional white space (using the @space@+-- parser), then it runs the parser @p@ which should return a number. Sign+-- of the number is changed according to the previously parsed sign -- character. -- -- For example, to parse signed integer you can write:@@ -494,11 +538,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,10 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Class -- Copyright : © 2015–present Megaparsec contributors@@ -13,31 +20,26 @@ -- 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 {-# SOURCE #-} Text.Megaparsec.Internal (Reply) 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,32 +47,27 @@ -- __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+ -- control position of the error without manipulating the 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 "" - -- | The parser @'try' p@ behaves like parser @p@, except that it+ -- | The parser @'try' p@ behaves like the parser @p@, except that it -- backtracks the parser state when @p@ fails (either consuming input or -- not). --@@ -108,7 +105,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,69 +112,67 @@ -- (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@- -- fails. In this case @r@ is called with the actual 'ParseError' as its- -- argument. Typical usage is to return a value signifying failure to+ -- | @'withRecovery' r p@ allows us to continue parsing even if the parser+ -- @p@ fails. In this case @r@ is called with the actual 'ParseError' as+ -- its argument. Typical usage is to return a value signifying failure to -- parse this particular object and to consume some part of the input up -- to the point where the next object starts. --- -- Note that if @r@ fails, original error message is reported as if- -- without 'withRecovery'. In no way recovering parser @r@ can influence+ -- Note that if @r@ fails, the original error message is reported as if+ -- without 'withRecovery'. In no way can the recovering parser @r@ influence -- 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- -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right'- -- as usual. Note that this primitive just allows you to observe parse- -- errors as they happen, it does not backtrack or change how the @p@- -- parser works in any way.+ -- | @'observing' p@ allows us to “observe” failure of the @p@ parser,+ -- should it happen, without actually ending parsing but instead getting+ -- the 'ParseError' in 'Left'. On success parsed value is returned in+ -- 'Right' as usual. Note that this primitive just allows you to observe+ -- parse errors as they happen, it does not backtrack or change how the+ -- @p@ 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- -- @x@ when the function @test t@ returns @'Just' x@. @expected@ specifies- -- the collection of expected items to report in error messages.+ -- | The parser @'token' test expected@ accepts tokens for which the+ -- matching function @test@ returns 'Just' results. If 'Nothing' is+ -- returned the @expected@ set is used to report the items that were+ -- expected. --- -- This is the most primitive combinator for accepting tokens. For- -- example, the 'Text.Megaparsec.satisfy' parser is implemented as:+ -- For example, the 'Text.Megaparsec.satisfy' parser is implemented as: --- -- > satisfy f = token testToken E.empty+ -- > satisfy f = token testToken Set.empty -- > where -- > testToken x = if f x then Just x else Nothing -- -- __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) ->+ -- | Used in the error message to mention the items that were expected+ 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,252 +198,282 @@ -- 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+ -- Try to use this as much as possible because for many streams this -- combinator is much faster than parsers built with -- 'Control.Monad.Combinators.many' and 'Text.Megaparsec.satisfy'. --- -- The following equations should clarify the behavior:- -- -- > takeWhileP (Just "foo") f = many (satisfy f <?> "foo") -- > takeWhileP Nothing f = many (satisfy f) -- -- 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.+ -- token. Try to use this as much as possible because for many streams+ -- this combinator is much faster than parsers built with+ -- 'Control.Monad.Combinators.some' and 'Text.Megaparsec.satisfy'. --+ -- > takeWhile1P (Just "foo") f = some (satisfy f <?> "foo")+ -- > takeWhile1P Nothing f = some (satisfy f)+ --+ -- 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+ -- return them packed as a chunk of stream. If there are not enough tokens -- in the stream, a parse error will be signaled. It's guaranteed that if -- the parser succeeds, the requested number of tokens will be returned. -- -- 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 () + -- | An escape hatch for defining custom 'MonadParsec' primitives. You+ -- will need to import "Text.Megaparsec.Internal" in order to construct+ -- 'Reply'.+ --+ -- @since 9.4.0+ mkParsec :: (State s e -> Reply e s a) -> m a+ ---------------------------------------------------------------------------- -- Lifting through MTL -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 ->+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 -> (,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)+ mkParsec f = lift (mkParsec 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 ->+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 -> (,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)+ mkParsec f = lift (mkParsec 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+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 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)+ mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where- parseError e = lift (parseError e)- 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)+ mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where- parseError e = lift (parseError e)- 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)+ mkParsec f = lift (mkParsec f) -- | @since 5.2.0- instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where- 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)+ mkParsec f = lift (mkParsec f) -- | @since 5.2.0- instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where- 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)+ mkParsec f = lift (mkParsec 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+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 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+ mkParsec f = lift (mkParsec 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' :: (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) {-# INLINE fixs' #-}
Text/Megaparsec/Common.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+ -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors@@ -11,32 +14,29 @@ -- 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 :: (MonadParsec e s m) => Tokens s -> m (Tokens s) string = chunk {-# INLINE string #-} -- | The same as 'string', but case-insensitive. On success returns string--- cased as actually parsed input.+-- cased as the parsed input. -- -- >>> 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,9 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Unsafe #-}+ -- | -- Module : Text.Megaparsec.Debug -- Copyright : © 2015–present Megaparsec contributors@@ -10,130 +16,318 @@ -- Debugging helpers. -- -- @since 7.0.0--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Text.Megaparsec.Debug- ( dbg )+ ( MonadParsecDbg (..),+ dbg',+ ) where +import Control.Monad.Identity (IdentityT, mapIdentityT)+import qualified Control.Monad.Trans.RWS.Lazy as L+import qualified Control.Monad.Trans.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+import Data.Bifunctor (Bifunctor (first))+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE import Data.Proxy+import qualified Data.Set as E import Debug.Trace+import Text.Megaparsec.Class (MonadParsec) import Text.Megaparsec.Error 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--- to refer to this parser in the debugging output. This combinator uses the--- 'trace' function from "Debug.Trace" under the hood.+-- | Type class describing parser monads that can trace during evaluation. ----- Typical usage is to wrap every sub-parser in misbehaving parser with--- 'dbg' assigning meaningful labels. Then give it a shot and go through the--- print-out. As of current version, this combinator prints all available--- information except for /hints/, which are probably only interesting to--- the maintainer of Megaparsec itself and may be quite verbose to output in--- general. Let me know if you would like to be able to see hints in the--- debugging output.+-- @since 9.3.0+class (MonadParsec e s m) => MonadParsecDbg e s m where+ -- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated+ -- it prints information useful for debugging. The @label@ is only used to+ -- refer to this parser in the debugging output. This combinator uses the+ -- 'trace' function from "Debug.Trace" under the hood.+ --+ -- Typical usage is to wrap every sub-parser in misbehaving parser with+ -- 'dbg' assigning meaningful labels. Then give it a shot and go through the+ -- print-out. As of current version, this combinator prints all available+ -- information except for /hints/, which are probably only interesting to+ -- the maintainer of Megaparsec itself and may be quite verbose to output in+ -- general. Let me know if you would like to be able to see hints in the+ -- debugging output.+ --+ -- The output itself is pretty self-explanatory, although the following+ -- abbreviations should be clarified (they are derived from the low-level+ -- source code):+ --+ -- * @COK@—“consumed OK”. The parser consumed input and succeeded.+ -- * @CERR@—“consumed error”. The parser consumed input and failed.+ -- * @EOK@—“empty OK”. The parser succeeded without consuming input.+ -- * @EERR@—“empty error”. The parser failed without consuming input.+ --+ -- __Note__: up until the version /9.3.0/ this was a non-polymorphic+ -- function that worked only in 'ParsecT'. It was first introduced in the+ -- version /7.0.0/.+ dbg ::+ (Show a) =>+ -- | Debugging label+ String ->+ -- | Parser to debug+ m a ->+ -- | Parser that prints debugging messages+ m a++-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: ----- The output itself is pretty self-explanatory, although the following--- abbreviations should be clarified (they are derived from the low-level--- source code):+-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ)+-- >>> parseTest (runStateT p 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2)+-- ((),2)+instance+ (Show st, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (L.StateT st m)+ where+ dbg str sma = L.StateT $ \s ->+ dbgWithComment "STATE" str $ L.runStateT sma s++-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: ----- * @COK@—“consumed OK”. The parser consumed input and succeeded.--- * @CERR@—“consumed error”. The parser consumed input and failed.--- * @EOK@—“empty OK”. The parser succeeded without consuming input.--- * @EERR@—“empty error”. The parser failed without consuming input.+-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ)+-- >>> parseTest (runStateT p 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2)+-- ((),2)+instance+ (Show st, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (S.StateT st m)+ where+ dbg str sma = S.StateT $ \s ->+ dbgWithComment "STATE" str $ S.runStateT sma s++instance+ (MonadParsecDbg e s m) =>+ MonadParsecDbg e s (L.ReaderT r m)+ where+ dbg = L.mapReaderT . dbg++-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@: ----- Finally, it's not possible to lift this function into some monad--- transformers without introducing surprising behavior (e.g. unexpected--- state backtracking) or adding otherwise redundant constraints (e.g.--- 'Show' instance for state), so this helper is only available for--- 'ParsecT' monad, not any instance of 'Text.Megaparsec.MonadParsec' in--- general.+-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1])+-- >>> parseTest (runWriterT p) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (LOG: [1])+-- ((),[0,1])+instance+ (Monoid w, Show w, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (L.WriterT w m)+ where+ dbg str wma = L.WriterT $ dbgWithComment "LOG" str $ L.runWriterT wma -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 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'+-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@:+--+-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1])+-- >>> parseTest (runWriterT p) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (LOG: [1])+-- ((),[0,1])+instance+ (Monoid w, Show w, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (S.WriterT w m)+ where+ dbg str wma = S.WriterT $ dbgWithComment "LOG" str $ S.runWriterT wma --- | A single piece of info to be rendered with 'dbgLog'.+-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its+-- final state is printed:+--+-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ)+-- >>> parseTest (runRWST p () 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2) (LOG: [1])+-- ((),2,[0,1])+instance+ (Monoid w, Show w, Show st, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (L.RWST r w st m)+ where+ dbg str sma = L.RWST $ \r s -> do+ let smth =+ (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w))+ <$> L.runRWST sma r s+ ((a, st), w) <- first unComment . unComment <$> dbg str smth+ pure (a, st, w) +-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its+-- final state is printed:+--+-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ)+-- >>> parseTest (runRWST p () 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2) (LOG: [1])+-- ((),2,[0,1])+instance+ (Monoid w, Show w, Show st, MonadParsecDbg e s m) =>+ MonadParsecDbg e s (S.RWST r w st m)+ where+ dbg str sma = S.RWST $ \r s -> do+ let smth =+ (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w))+ <$> S.runRWST sma r s+ ((a, st), w) <- first unComment . unComment <$> dbg str smth+ pure (a, st, w)++instance (MonadParsecDbg e s m) => MonadParsecDbg e s (IdentityT m) where+ dbg = mapIdentityT . dbg++-- | @'dbgWithComment' label_a label_c m@ traces the first component of the+-- result produced by @m@ with @label_a@ and the second component with+-- @label_b@.+dbgWithComment ::+ (MonadParsecDbg e s m, Show a, Show c) =>+ -- | Debugging label (for @a@)+ String ->+ -- | Extra component label (for @c@)+ String ->+ -- | Parser to debug+ m (a, c) ->+ -- | Parser that prints debugging messages+ m (a, c)+dbgWithComment lbl str ma =+ unComment <$> dbg str (ShowComment lbl <$> ma)++-- | A wrapper with a special show instance:+--+-- >>> show (ShowComment "STATE" ("Hello, world!", 42))+-- Hello, world! (STATE: 42)+data ShowComment c a = ShowComment String (a, c)++unComment :: ShowComment c a -> (a, c)+unComment (ShowComment _ val) = val++instance (Show c, Show a) => Show (ShowComment c a) where+ show (ShowComment lbl (a, c)) = show a ++ " (" ++ lbl ++ ": " ++ show c ++ ")"++instance+ (VisualStream s, ShowErrorComponent e) =>+ MonadParsecDbg e s (ParsecT e s m)+ where+ dbg lbl p = ParsecT $ \s cok cerr eok eerr ->+ let l = dbgLog lbl+ 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 hs)+ 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 hs)+ 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 (Hints (Token s)) | DbgCERR [Token s] (ParseError s e)- | DbgEOK [Token s] a+ | DbgEOK [Token s] a (Hints (Token s)) | DbgEERR [Token s] (ParseError s e) -- | Render a single piece of debugging info.--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+ showHints hs = "[" ++ List.intercalate "," (showErrorItem pxy <$> E.toAscList hs) ++ "]" msg = case item of- DbgIn ts ->+ DbgIn ts -> "IN: " ++ showStream pxy ts- DbgCOK ts a ->- "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+ DbgCOK ts a (Hints hs) ->+ "MATCH (COK): "+ ++ showStream pxy ts+ ++ "\nVALUE: "+ ++ show a+ ++ "\nHINTS: "+ ++ showHints hs DbgCERR ts e -> "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e- DbgEOK ts a ->- "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+ DbgEOK ts a (Hints hs) ->+ "MATCH (EOK): "+ ++ showStream pxy ts+ ++ "\nVALUE: "+ ++ show a+ ++ "\nHINTS: "+ ++ showHints hs DbgEERR ts e -> "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e -- | 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 :: forall s. (Stream s) => Int -> s -> [Token s] streamTake n s = case fst <$> takeN_ n s of Nothing -> [] Just chk -> chunkToTokens (Proxy :: Proxy s) chk++-- | Just like 'dbg', but doesn't require the return value of the parser to+-- be 'Show'-able.+--+-- @since 9.1.0+dbg' ::+ (MonadParsecDbg e s m) =>+ -- | Debugging label+ String ->+ -- | Parser to debug+ m a ->+ -- | Parser that prints debugging messages+ m a+dbg' lbl p = unBlind <$> dbg lbl (Blind <$> p)++-- | A wrapper type with a dummy 'Show' instance.+newtype Blind x = Blind {unBlind :: x}++instance Show (Blind x) where+ show _ = "NOT SHOWN"
Text/Megaparsec/Error.hs view
@@ -1,3 +1,16 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Error -- Copyright : © 2015–present Megaparsec contributors@@ -7,95 +20,90 @@ -- Stability : experimental -- Portability : portable ----- Parse errors. The current version of Megaparsec supports well-typed--- errors instead of 'String'-based ones. This gives a lot of flexibility in+-- Parse errors. The current version of Megaparsec supports typed errors+-- instead of 'String'-based ones. This gives a lot of flexibility in -- describing what exactly went wrong as well as a way to return arbitrary -- data in case of failure. -- -- 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,+ errorBundlePrettyForGhcPreProcessors,+ errorBundlePrettyWith,+ parseErrorPretty,+ parseErrorTextPretty,+ showErrorItem,+ ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception import Control.Monad.State.Strict 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+import qualified Text.Megaparsec.Unicode as Unicode ---------------------------------------------------------------------------- -- Parse error type --- | Data type that is used to represent “unexpected\/expected” items in--- 'ParseError'. The data type is parametrized over the token type @t@.+-- | A data type that is used to represent “unexpected\/expected” items in+-- 'ParseError'. It 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- deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+ = -- | 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, Generic, Functor) -instance NFData t => NFData (ErrorItem t)+instance (NFData t) => NFData (ErrorItem t) -- | Additional error data, extendable by user. When no custom data is -- necessary, the type is typically indexed by 'Void' to “cancel” the -- '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- deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+ ErrorIndentation Ordering Pos Pos+ | -- | Custom error data+ ErrorCustom e+ deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData a => NFData (ErrorFancy a) where+instance (NFData a) => NFData (ErrorFancy a) where rnf (ErrorFail str) = rnf str rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act rnf (ErrorCustom a) = rnf a@@ -103,89 +111,96 @@ -- | @'ParseError' s e@ represents a parse error parametrized over the -- stream type @s@ and the custom data @e@. ----- 'Semigroup' and 'Monoid' instances of the data type allow to merge parse--- errors from different branches of parsing. When merging two+-- 'Semigroup' and 'Monoid' instances of the data type allow us to merge+-- parse errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. Note that -- 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 the 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/.- deriving (Typeable, Generic)+ FancyError Int (Set (ErrorFancy e))+ deriving (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 (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'.+-- | Get the offset of a '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'.+-- | Set the offset of a '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 +210,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,75 +236,84 @@ -- 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) {-# INLINE mergeError #-} -- | A non-empty collection of 'ParseError's equipped with 'PosState' that--- allows to pretty-print the errors efficiently and correctly.+-- allows us 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)--deriving instance ( Show s- , Show (Token s)- , Show e- ) => Show (ParseErrorBundle s e)+ { -- | A collection of 'ParseError's that is sorted by parse error offsets+ bundleErrors :: NonEmpty (ParseError s e),+ -- | The state that is used for line\/column calculation+ bundlePosState :: PosState s+ }+ deriving (Generic) -deriving instance ( Eq s- , Eq (Token s)- , Eq e- ) => Eq (ParseErrorBundle s e)+deriving instance+ ( Show s,+ Show (Token s),+ Show e+ ) =>+ Show (ParseErrorBundle s e) -deriving instance ( Typeable s- , Typeable (Token s)- , Typeable e- ) => Typeable (ParseErrorBundle s e)+deriving instance+ ( Eq s,+ Eq (Token s),+ Eq e+ ) =>+ Eq (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--- there is a projection allowing to get an offset per item.+-- there is a projection allowing us to get an offset per item. -- -- 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 +329,14 @@ -- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0--class Ord a => ShowErrorComponent a where-+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 @@ -324,48 +344,94 @@ showErrorComponent = absurd -- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will--- be pretty-printed in order together with the corresponding offending--- lines by doing a single efficient pass over the input stream. The--- rendered 'String' always ends with a newline.+-- be pretty-printed in order, by applying a provided format function, with+-- a single pass over the input stream. ----- @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 ParseErrorBundle {..} =+-- @since 9.7.0+errorBundlePrettyWith ::+ forall s e.+ ( VisualStream s,+ TraversableStream s+ ) =>+ -- | Format function for a single 'ParseError'+ (Maybe String -> SourcePos -> ParseError s e -> String) ->+ -- | Parse error bundle to display+ ParseErrorBundle s e ->+ -- | Textual rendition of the bundle+ String+errorBundlePrettyWith format ParseErrorBundle {..} = let (r, _) = foldl f (id, bundlePosState) bundleErrors- in drop 1 (r "")+ in 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 = format msline epos e++-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order together with the corresponding offending+-- lines by doing a single pass over the input stream. The rendered 'String'+-- always ends with a newline.+--+-- @since 7.0.0+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 = drop 1 . errorBundlePrettyWith format+ where+ format ::+ Maybe String ->+ SourcePos ->+ ParseError s e ->+ String+ format msline epos e = outChunk+ where 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 max 1 elen+ pointer = replicate pointerLen '^'+ lineNumber = (show . unPos . sourceLine) epos+ padding = replicate (length lineNumber + 1) ' '+ rpshift = unPos (sourceColumn epos) - 1+ slineLen = Unicode.stringLength sline+ in padding+ <> "|\n"+ <> lineNumber+ <> " | "+ <> sline+ <> "\n"+ <> padding+ <> "| "+ <> rpadding+ <> pointer+ <> "\n" pxy = Proxy :: Proxy s elen = case e of@@ -374,15 +440,51 @@ FancyError _ xs -> E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order by doing a single pass over the input stream.+--+-- The rendered format is suitable for custom GHC pre-processors (as can be+-- specified with -F -pgmF).+--+-- @since 9.7.0+errorBundlePrettyForGhcPreProcessors ::+ forall s e.+ ( VisualStream s,+ TraversableStream s,+ ShowErrorComponent e+ ) =>+ -- | Parse error bundle to display+ ParseErrorBundle s e ->+ -- | Textual rendition of the bundle+ String+errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format+ where+ format ::+ Maybe String ->+ SourcePos ->+ ParseError s e ->+ String+ format _msline epos e =+ sourcePosPretty epos+ <> ":"+ <> indent (parseErrorTextPretty e)++ indent :: String -> String+ indent =+ lines >>> \case+ [err] -> err+ err -> intercalate "\n" $ map (" " <>) err+ -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- 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 +493,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,57 +517,60 @@ -- Helpers -- | Pretty-print an 'ErrorItem'.--showErrorItem :: Stream s => Proxy s -> ErrorItem (Token s) -> String+--+-- @since 9.4.0+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 :: (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 :: (ShowErrorComponent e) => ErrorFancy e -> Int errorFancyLength = \case ErrorCustom a -> errorComponentLen a- _ -> 1---- | Transforms a list of error messages into their textual representation.+ _ -> 1 -messageItemsPretty- :: String -- ^ Prefix to prepend- -> Set String -- ^ Collection of messages- -> String -- ^ Result of rendering+-- | Transform a list of error messages into their textual representation.+messageItemsPretty ::+ -- | Prefix to prepend+ String ->+ -- | Collection of messages+ Set String ->+ -- | Result of rendering+ String messageItemsPretty prefix ts | E.null ts = "" | otherwise =- prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n"+ prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n" -- | 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,8 @@ {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE Safe #-} module Text.Megaparsec.Error- ( ParseError+ ( ParseError, ) where
Text/Megaparsec/Error/Builder.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Error.Builder -- Copyright : © 2015–present Megaparsec contributors@@ -11,189 +19,174 @@ -- 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 Data.Typeable (Typeable)+import qualified Data.Set as E 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)+ deriving (Generic) -deriving instance Eq (Token s) => Eq (ET s)+deriving instance (Eq (Token s)) => Eq (ET s) -deriving instance Ord (Token s) => Ord (ET s)+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+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+instance (Stream s) => Monoid (ET s) where+ 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)+ deriving (Eq, Ord, Data, Generic) -instance Ord e => Semigroup (EF e) where+instance (Ord e) => Semigroup (EF e) where EF xs0 <> EF xs1 = EF (E.union xs0 xs1) -instance Ord e => Monoid (EF e) where- mempty = EF E.empty+instance (Ord e) => Monoid (EF e) where+ mempty = EF E.empty mappend = (<>) ---------------------------------------------------------------------------- -- Top-level helpers --- | 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'+-- | Assemble a 'ParseError' from the offset and the @'ET' t@ value. @'ET'+-- t@ is a monoid and can be assembled by combining primitives provided by+-- this module, see below.+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 :: 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 :: 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 :: 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 :: ET s ueof = unexp EndOfInput -- | Construct an “expected token” error component.--etok :: Stream s => Token s -> ET s+etok :: 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 :: 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 :: 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 :: ET s eeof = expe EndOfInput -- | Construct a custom error component.- fancy :: ErrorFancy e -> EF e fancy = EF . E.singleton ---------------------------------------------------------------------------- -- Helpers --- | Construct appropriate 'ErrorItem' representation for given token--- stream. Empty string produces 'EndOfInput'.--canonicalizeTokens- :: Stream s- => Proxy s- -> Tokens s- -> ErrorItem (Token s)+-- | Construct the appropriate 'ErrorItem' representation for the given+-- token stream. The empty string produces 'EndOfInput'.+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 :: 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 :: 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,16 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Internal -- Copyright : © 2015–present Megaparsec contributors@@ -13,55 +26,47 @@ -- 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,+ refreshHints,+ runParsecT,+ withParsecT,+ ) where import Control.Applicative import Control.Monad+import qualified Control.Monad.Combinators 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 Control.Monad.Writer.Class 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,49 +89,57 @@ -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input+newtype Hints t = Hints (Set (ErrorItem t)) -newtype Hints t = Hints [Set (ErrorItem t)]- deriving (Semigroup, Monoid)+instance (Ord t) => Semigroup (Hints t) where+ Hints xs <> Hints ys = Hints $ xs <> ys +instance (Ord t) => Monoid (Hints t) where+ mempty = Hints mempty+ -- | All information available after parsing. This includes consumption of--- input, success (with returned value) or failure (with parse error), and--- parser state at the end of parsing.+-- input, success (with the returned value) or failure (with the parse+-- error), and parser state at the end of parsing. 'Reply' can also be used+-- to resume parsing. -- -- See also: 'Consumption', 'Result'.- data Reply e s a = Reply (State s e) Consumption (Result s e a)+ deriving (Functor) -- | 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+ NotConsumed -- | Whether the parser has failed or not. On success we include the -- resulting value, on failure we include a 'ParseError'. -- -- See also: 'Consumption', 'Reply'.- data Result s e a- = OK a -- ^ Parser succeeded- | Error (ParseError s e) -- ^ Parser failed+ = -- | Parser succeeded (includes hints)+ OK (Hints (Token s)) a+ | -- | Parser failed+ Error (ParseError s e)+ deriving (Functor) -- | @'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 +147,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 +156,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,103 +171,174 @@ {-# INLINE pMap #-} -- | 'pure' returns a parser that __succeeds__ without consuming input.--instance Stream s => Applicative (ParsecT e s m) where- pure = pPure- (<*>) = pAp+instance (Stream s) => Applicative (ParsecT e s m) where+ pure = pPure+ (<*>) = pAp p1 *> p2 = p1 `pBind` const p2- p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }+ {-# INLINE (*>) #-}+ p1 <* p2 = do x1 <- p1; void p2; return x1+ {-# INLINE (<*) #-} -pPure :: a -> ParsecT e s m a+pPure :: (Stream s) => 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+ many = Control.Monad.Combinators.many+ some = Control.Monad.Combinators.some -- | 'return' returns a parser that __succeeds__ without consuming input.--instance Stream s => Monad (ParsecT e s m) where+instance (Stream s) => Monad (ParsecT e s m) where return = pure- (>>=) = pBind-#if !(MIN_VERSION_base(4,13,0))- fail = Fail.fail-#endif+ (>>=) = pBind -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+instance (Stream s) => Fail.MonadFail (ParsecT e s m) where fail = pFail 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- local f p = mkPT $ \s -> local f (runParsecT p s)+ ask = lift ask+ local f = hoistP (local f) instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put +hoistP ::+ (Monad m) =>+ (m (Reply e s a) -> m (Reply e s b)) ->+ ParsecT e s m a ->+ ParsecT e s m b+hoistP h p = mkParsecT (h . runParsecT p)++-- | @since 9.5.0+instance (Stream s, MonadWriter w m) => MonadWriter w (ParsecT e s m) where+ tell w = lift (tell w)+ listen = hoistP (fmap (\(repl, w) -> fmap (,w) repl) . listen)+ pass = hoistP $ \m -> pass $ do+ Reply st consumption r <- m+ let (r', ww') = case r of+ OK hs (x, ww) -> (OK hs x, ww)+ Error e -> (Error e, id)+ return (Reply st consumption r', ww')+ instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where- callCC f = mkPT $ \s ->+ callCC f = mkParsecT $ \s -> callCC $ \c ->- runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s- where pack s a = Reply s Virgin (OK a)+ runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s+ where+ pack s a = Reply s NotConsumed (OK mempty a) instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError- p `catchError` h = mkPT $ \s ->+ p `catchError` h = mkParsecT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s -mkPT :: Monad m => (State s e -> m (Reply e s a)) -> ParsecT e s m a-mkPT k = ParsecT $ \s cok cerr eok eerr -> do+mkParsecT ::+ (Monad m) =>+ (State s e -> m (Reply e s a)) ->+ ParsecT e s m a+mkParsecT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of- OK x -> cok x s' mempty+ OK hs x -> cok x s' hs Error e -> cerr e s'- Virgin ->+ NotConsumed -> case result of- OK x -> eok x s' mempty+ OK hs x -> eok x s' hs Error e -> eerr e s'+{-# INLINE mkParsecT #-} --- | 'mzero' is a parser that __fails__ without consuming input.+pmkParsec ::+ (State s e -> Reply e s a) ->+ ParsecT e s m a+pmkParsec k = ParsecT $ \s cok cerr eok eerr ->+ let (Reply s' consumption result) = k s+ in case consumption of+ Consumed ->+ case result of+ OK hs x -> cok x s' hs+ Error e -> cerr e s'+ NotConsumed ->+ case result of+ OK hs x -> eok x s' hs+ Error e -> eerr e s'+{-# INLINE pmkParsec #-} +-- | 'mzero' is a parser that __fails__ without consuming input.+--+-- __Note__: strictly speaking, this instance is unlawful. The right+-- identity law does not hold, e.g. in general this is not true:+--+-- > v >> mzero = mzero+--+-- However the following holds:+--+-- > try v >> mzero = mzero instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus@@ -264,23 +348,46 @@ 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)- 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+ neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs)+ neerr err' s' =+ let combinedErr = combineErrors (stateOffset s) err err'+ in eerr combinedErr (longestMatch ms s')+ in unParser n s cok ncerr neok neerr+ in unParser m s cok cerr eok meerr+ where+ combineErrors altOffset e1 e2 = case (e1, e2) of+ (TrivialError o1 u1 p1, TrivialError o2 u2 p2) ->+ -- When merging alternative errors, if one is ahead due to try, we+ -- bring both to the alternative position and union their expected+ -- tokens.+ if o1 > altOffset || o2 > altOffset+ then+ -- At least one error is ahead, normalize to alt position. Only+ -- include expected tokens from errors at the alt position.+ let p1' = if o1 == altOffset then p1 else E.empty+ p2' = if o2 == altOffset then p2 else E.empty+ -- Use the unexpected from the error at alt position, or the+ -- furthest.+ unexp = case (o1 `compare` altOffset, o2 `compare` altOffset) of+ (EQ, _) -> u1+ (_, EQ) -> u2+ _ -> if o1 >= o2 then u1 else u2+ in TrivialError altOffset unexp (E.union p1' p2')+ else e2 <> e1+ _ -> e2 <> e1 {-# 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,39 +397,38 @@ {-# 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"+ mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do+ let a = case result of+ OK _ a' -> a'+ Error _ -> error "mfix ParsecT" runParsecT (f a) s -instance MonadTrans (ParsecT e s) where+instance (Stream s) => MonadTrans (ParsecT e s) where lift amb = ParsecT $ \s _ _ eok _ -> 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+ mkParsec = pmkParsec -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 #-} @@ -331,129 +437,139 @@ let el = Label <$> NE.nonEmpty l cok' x s' hs = case el of- Nothing -> cok x s' (refreshLastHint hs Nothing)- Just _ -> cok x s' hs- eok' x s' hs = eok x s' (refreshLastHint hs el)- eerr' err = eerr $+ Nothing -> cok x s' (refreshHints hs Nothing)+ Just _ -> cok x s' hs+ eok' x s' hs = eok x s' (refreshHints hs el)+ 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 :: (Stream s) => 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 ()+pNotFollowedBy :: (Stream s) => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input o _ _) _ _ eok eerr -> 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- eok' _ _ _ = eerr (unexpect what) s- eerr' _ _ = eok () s mempty- in unParser p s cok' cerr' eok' eerr'+ unexpected u = TrivialError o (pure u) E.empty+ cok' _ _ _ = eerr (unexpected what) s+ cerr' _ _ = eok () s mempty+ eok' _ _ _ = eerr (unexpected what) s+ 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 :: 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 =+ unexpected 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 (unexpected 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 (unexpected 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@@ -461,16 +577,18 @@ hs = 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+ Just l -> (Hints . 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 {-# 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@@ -479,42 +597,49 @@ hs = 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+ Just l -> (Hints . 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 {-# INLINE pTakeWhile1P #-} -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+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 n = max 0 n'+ 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)+pGetParserState :: (Stream s) => ParsecT e s m (State s e) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s e -> State s e) -> ParsecT e s m ()+pUpdateParserState :: (Stream s) => (State s e -> State s e) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} @@ -525,13 +650,14 @@ ---------------------------------------------------------------------------- -- 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)+-- | Convert a 'ParseError' record into 'Hints'.+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@@ -539,91 +665,103 @@ -- there might have been backtracking with 'try' and in that case we -- must not convert such a parse error to hints. if streamPos == errOffset- then Hints (if E.null ps then [] else [ps])+ then Hints (if E.null ps then E.empty else ps) else mempty FancyError _ _ -> mempty {-# INLINE toHints #-} -- | @'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')))+ TrivialError pos us ps -> c (TrivialError pos us (E.union ps ps')) _ -> c e {-# INLINE withHints #-} -- | @'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 ::+ (Stream s) =>+ -- | 'Hints' to add+ Hints (Token s) ->+ -- | An “OK” continuation to alter+ (a -> State s e -> Hints (Token s) -> m b) ->+ -- | Altered “OK” continuation+ (a -> State s e -> Hints (Token s) -> 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)-{-# INLINE refreshLastHint #-}+-- | Replace the hints with the given 'ErrorItem' (or delete it if 'Nothing'+-- is given). This is used in the 'label' primitive.+refreshHints :: Hints t -> Maybe (ErrorItem t) -> Hints t+refreshHints (Hints _) Nothing = Hints E.empty+refreshHints (Hints hs) (Just m) =+ if E.null hs+ then Hints hs+ else Hints (E.singleton m)+{-# INLINE refreshHints #-} -- | 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' hs = return $ Reply s' Consumed (OK hs a) cerr err s' = return $ Reply s' Consumed (Error err)- eok a s' _ = return $ Reply s' Virgin (OK a)- eerr err s' = return $ Reply s' Virgin (Error err)+ eok a s' hs = return $ Reply s' NotConsumed (OK hs a)+ eerr err s' = return $ Reply s' NotConsumed (Error err) -- | Transform any custom errors thrown by the parser using the given -- function. Similar in function and purpose to @withExceptT@. ----- __Note__ that the inner parser will start with empty collection of+-- __Note__ that the inner parser will start with an empty collection of -- “delayed” 'ParseError's. Any delayed 'ParseError's produced in the inner -- parser will be lifted by applying the provided function and added to the -- 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.+ (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'- where+ in unParser p s' cok' cerr' eok' eerr' {-# INLINE withParsecT #-}
+ Text/Megaparsec/Internal.hs-boot view
@@ -0,0 +1,10 @@+{-# LANGUAGE RoleAnnotations #-}++module Text.Megaparsec.Internal+ ( Reply,+ )+where++type role Reply nominal nominal representational++data Reply e s a
Text/Megaparsec/Lexer.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+ -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors@@ -11,36 +14,35 @@ -- 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 --- | @'space' sc lineComment blockComment@ produces parser that can parse+-- | @'space' sc lineComment blockComment@ produces a parser that can parse -- white space in general. It's expected that you create such a parser once -- and pass it to other functions in this module as needed (when you see -- @spaceConsumer@ in documentation, usually it means that something like -- 'space' is expected there). ----- @sc@ is used to parse blocks of space characters. You can use 'C.space1'--- from "Text.Megaparsec.Char" for this purpose as well as your own parser--- (if you don't want to automatically consume newlines, for example). Make--- sure the parser does not succeed on empty input though. In earlier--- version 'C.spaceChar' was recommended, but now parsers based on--- 'takeWhile1P' are preferred because of their speed.+-- @sc@ is used to parse blocks of space characters. You can use+-- 'Text.Megaparsec.Char.space1' from "Text.Megaparsec.Char" for this+-- purpose as well as your own parser (if you don't want to automatically+-- consume newlines, for example). Make sure that the parser does not+-- succeed on the empty input though. In an earlier version of the library+-- 'Text.Megaparsec.Char.spaceChar' was recommended, but now parsers based+-- on 'takeWhile1P' are preferred because of their speed. -- -- @lineComment@ is used to parse line comments. You can use -- @skipLineComment@ if you don't need anything special.@@ -53,28 +55,35 @@ -- 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. 'Text.Megaparsec.Char.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+-- | This is a wrapper for lexemes. The typical usage is to supply the first -- argument (parser that consumes white space, probably defined via 'space') -- and use the resulting function to wrap parsers for every lexeme. -- -- > 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 +101,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+-- | A 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,8 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}+ -- | -- Module : Text.Megaparsec.Pos -- Copyright : © 2015–present Megaparsec contributors@@ -12,29 +17,25 @@ -- -- 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 import Control.Exception import Data.Data (Data)-import Data.Typeable (Typeable) import GHC.Generics ----------------------------------------------------------------------------@@ -46,15 +47,13 @@ -- together. -- -- @since 5.0.0- newtype Pos = Pos Int- deriving (Show, Eq, Ord, Data, Typeable, NFData)+ deriving (Show, Eq, Ord, Data, Generic, NFData) -- | Construction of 'Pos' from 'Int'. The function throws -- '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'- deriving (Eq, Show, Data, Typeable, Generic)+newtype InvalidPosException+ = -- | Contains the actual value that was passed to 'mkPos'+ InvalidPosException Int+ deriving (Eq, Show, Data, 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, 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,10 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.State -- Copyright : © 2015–present Megaparsec contributors@@ -12,77 +19,115 @@ -- 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 (..),+ initialState,+ PosState (..),+ initialPosState,+ ) 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 (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) --- | Special kind of state that is used to calculate line\/column positions--- on demand.+-- | Given the name of the source file and the input construct the initial+-- state for a parser. ----- @since 7.0.0+-- @since 9.6.0+initialState ::+ -- | Name of the file the input is coming from+ FilePath ->+ -- | Input+ s ->+ State s e+initialState name s =+ State+ { stateInput = s,+ stateOffset = 0,+ statePosState = initialPosState name s,+ stateParseErrors = []+ } +-- | A special kind of state that is used to calculate line\/column+-- positions 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, Generic) -instance NFData s => NFData (PosState s)+instance (NFData s) => NFData (PosState s)++-- | Given the name of source file and the input construct the initial+-- positional state.+--+-- @since 9.6.0+initialPosState ::+ -- | Name of the file the input is coming from+ FilePath ->+ -- | Input+ s ->+ PosState s+initialPosState name s =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos name,+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ }
Text/Megaparsec/Stream.hs view
@@ -1,3 +1,15 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module : Text.Megaparsec.Stream -- Copyright : © 2015–present Megaparsec contributors@@ -13,47 +25,51 @@ -- "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 (..),+ ShareInput (..),+ NoShareInput (..),+ VisualStream (..),+ TraversableStream (..),+ ) where +import Data.Bifunctor (second)+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 (toList) import Data.Kind (Type)+import qualified Data.List 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+import qualified Text.Megaparsec.Unicode as Unicode -- | Type class for inputs that can be consumed by the library.-+--+-- Note that the 'Stream' instances for 'Text' and 'ByteString' (strict and+-- lazy) default to "input sharing" (see 'ShareInput', 'NoShareInput'). We plan+-- to move away from input sharing in a future major release; if you want to+-- retain the current behaviour and are concerned with maximum performance you+-- should consider using the 'ShareInput' wrapper explicitly.+--+-- __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 +79,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 +103,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 +123,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 +131,291 @@ -- 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++-- | This wrapper selects the input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). By input+-- sharing we mean that our parsers will use slices whenever possible to+-- avoid having to copy parts of the input. See also the documentation of+-- 'T.split'.+--+-- Note that using slices is in general faster than copying; on the other+-- hand it also has the potential for causing surprising memory leaks: if+-- any slice of the input survives in the output, holding on to the output+-- will force the entire input 'T.Text'/'B.ByteString' to stay in memory!+-- Even when using lazy 'TL.Text'/'BL.ByteString' we will hold on to whole+-- chunks at a time leading to to significantly worse memory residency in+-- some cases.+--+-- See 'NoShareInput' for a somewhat slower implementation that avoids this+-- memory leak scenario.+--+-- @since 9.3.0+newtype ShareInput a = ShareInput {unShareInput :: a}++instance Stream (ShareInput B.ByteString) where+ type Token (ShareInput B.ByteString) = Word8+ type Tokens (ShareInput 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_ (ShareInput s) = second ShareInput <$> B.uncons s+ takeN_ n (ShareInput s)+ | n <= 0 = Just (B.empty, ShareInput s)+ | B.null s = Nothing+ | otherwise = Just . second ShareInput $ B.splitAt n s+ takeWhile_ p (ShareInput s) = second ShareInput $ B.span p s++instance Stream (ShareInput BL.ByteString) where+ type Token (ShareInput BL.ByteString) = Word8+ type Tokens (ShareInput 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_ (ShareInput s) = second ShareInput <$> BL.uncons s+ takeN_ n (ShareInput s)+ | n <= 0 = Just (BL.empty, ShareInput s)+ | BL.null s = Nothing+ | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s+ takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s++instance Stream (ShareInput T.Text) where+ type Token (ShareInput T.Text) = Char+ type Tokens (ShareInput 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_ (ShareInput s) = second ShareInput <$> T.uncons s+ takeN_ n (ShareInput s)+ | n <= 0 = Just (T.empty, ShareInput s)+ | T.null s = Nothing+ | otherwise = Just . second ShareInput $ T.splitAt n s+ takeWhile_ p (ShareInput s) = second ShareInput $ T.span p s++instance Stream (ShareInput TL.Text) where+ type Token (ShareInput TL.Text) = Char+ type Tokens (ShareInput 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_ (ShareInput s) = second ShareInput <$> TL.uncons s+ takeN_ n (ShareInput s)+ | n <= 0 = Just (TL.empty, ShareInput s)+ | TL.null s = Nothing+ | otherwise = Just . second ShareInput $ TL.splitAt (fromIntegral n) s+ takeWhile_ p (ShareInput s) = second ShareInput $ TL.span p s++-- | This wrapper selects the no-input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). This means+-- that our parsers will create independent copies rather than using slices+-- of the input. See also the documentation of 'T.copy'.+--+-- More importantly, any parser output will be independent of the input, and+-- holding on to parts of the output will never prevent the input from being+-- garbage collected.+--+-- For maximum performance you might consider using 'ShareInput' instead,+-- but beware of its pitfalls!+--+-- @since 9.3.0+newtype NoShareInput a = NoShareInput {unNoShareInput :: a}++instance Stream (NoShareInput B.ByteString) where+ type Token (NoShareInput B.ByteString) = Word8+ type Tokens (NoShareInput 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_ (NoShareInput s) = second NoShareInput <$> B.uncons s+ takeN_ n (NoShareInput s)+ | n <= 0 = Just (B.empty, NoShareInput s)+ | B.null s = Nothing+ | otherwise =+ let (result, rest) = B.splitAt n s+ -- To avoid sharing the entire input we create a clean copy of the result.+ unSharedResult = B.copy result+ in Just (unSharedResult, NoShareInput rest)+ takeWhile_ p (NoShareInput s) =+ let (result, rest) = B.span p s+ -- Ditto.+ unSharedResult = B.copy result+ in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput BL.ByteString) where+ type Token (NoShareInput BL.ByteString) = Word8+ type Tokens (NoShareInput 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_ (NoShareInput s) = second NoShareInput <$> BL.uncons s+ takeN_ n (NoShareInput s)+ | n <= 0 = Just (BL.empty, NoShareInput s)+ | BL.null s = Nothing+ | otherwise =+ let (result, rest) = BL.splitAt (fromIntegral n) s+ -- To avoid sharing the entire input we create a clean copy of the result.+ unSharedResult = BL.copy result+ in Just (unSharedResult, NoShareInput rest)+ takeWhile_ p (NoShareInput s) =+ let (result, rest) = BL.span p s+ -- Ditto.+ unSharedResult = BL.copy result+ in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput T.Text) where+ type Token (NoShareInput T.Text) = Char+ type Tokens (NoShareInput 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_ (NoShareInput s) = second NoShareInput <$> T.uncons s+ takeN_ n (NoShareInput s)+ | n <= 0 = Just (T.empty, NoShareInput s)+ | T.null s = Nothing+ | otherwise =+ let (result, rest) = T.splitAt n s+ -- To avoid sharing the entire input we create a clean copy of the result.+ unSharedResult = T.copy result+ in Just (unSharedResult, NoShareInput rest)+ takeWhile_ p (NoShareInput s) =+ let (result, rest) = T.span p s+ unSharedResult = T.copy result+ in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput TL.Text) where+ type Token (NoShareInput TL.Text) = Char+ type Tokens (NoShareInput 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_ (NoShareInput s) = second NoShareInput <$> TL.uncons s+ takeN_ n (NoShareInput s)+ | n <= 0 = Just (TL.empty, NoShareInput s)+ | TL.null s = Nothing+ | otherwise =+ let (result, rest) = TL.splitAt (fromIntegral n) s+ -- To avoid sharing the entire input we create a clean copy of the result.+ unSharedResult = tlCopy result+ in Just (unSharedResult, NoShareInput rest)+ takeWhile_ p (NoShareInput s) =+ let (result, rest) = TL.span p s+ unSharedResult = tlCopy result+ in (unSharedResult, NoShareInput rest)++-- | Create an independent copy of a TL.Text, akin to BL.copy.+tlCopy :: TL.Text -> TL.Text+tlCopy = TL.fromStrict . T.copy . TL.toStrict+{-# INLINE tlCopy #-}++-- Since we are using @{-# LANGUAGE Safe #-}@ we can't use deriving via in+-- these cases.++instance Stream B.ByteString where+ type Token B.ByteString = Token (ShareInput B.ByteString)+ type Tokens B.ByteString = Tokens (ShareInput B.ByteString)+ tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput B.ByteString))+ tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput B.ByteString))+ chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput B.ByteString))+ chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput B.ByteString))+ chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput B.ByteString))+ take1_ s = second unShareInput <$> take1_ (ShareInput s)+ takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+ takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream BL.ByteString where+ type Token BL.ByteString = Token (ShareInput BL.ByteString)+ type Tokens BL.ByteString = Tokens (ShareInput BL.ByteString)+ tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+ tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+ chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput BL.ByteString))+ chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput BL.ByteString))+ chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput BL.ByteString))+ take1_ s = second unShareInput <$> take1_ (ShareInput s)+ takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+ takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream T.Text where+ type Token T.Text = Token (ShareInput T.Text)+ type Tokens T.Text = Tokens (ShareInput T.Text)+ tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput T.Text))+ tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput T.Text))+ chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput T.Text))+ chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput T.Text))+ chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput T.Text))+ take1_ s = second unShareInput <$> take1_ (ShareInput s)+ takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+ takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream TL.Text where+ type Token TL.Text = Token (ShareInput TL.Text)+ type Tokens TL.Text = Tokens (ShareInput TL.Text)+ tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput TL.Text))+ tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput TL.Text))+ chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput TL.Text))+ chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput TL.Text))+ chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput TL.Text))+ take1_ s = second unShareInput <$> take1_ (ShareInput s)+ takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+ takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++-- | 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 +423,42 @@ -- 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+ tokensLength Proxy = Unicode.stringLength++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+ tokensLength Proxy = Unicode.stringLength++instance VisualStream TL.Text where+ showTokens Proxy = stringPretty+ tokensLength Proxy = Unicode.stringLength++-- | 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 +477,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,280 +502,218 @@ -- /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 Data.List.foldl' id id ('\n', '\t') charInc o pst reachOffsetNoLine o pst =- reachOffsetNoLine' splitAt foldl' ('\n', '\t') o pst+ reachOffsetNoLine' splitAt Data.List.foldl' ('\n', '\t') charInc 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+ reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) byteInc o pst reachOffsetNoLine o pst =- reachOffsetNoLine' B.splitAt B.foldl' (10, 9) o pst+ reachOffsetNoLine' B.splitAt B.foldl' (10, 9) byteInc 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+ reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) byteInc o pst reachOffsetNoLine o pst =- reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) o pst+ reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) byteInc 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+ reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') charInc o pst reachOffsetNoLine o pst =- reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') o pst+ reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') charInc 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+ reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') charInc o pst reachOffsetNoLine o pst =- reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') o pst+ reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') charInc o pst ---------------------------------------------------------------------------- -- Helpers -- | An internal helper state type combining a difference 'String' and an -- unboxed 'SourcePos'.--data St = St SourcePos ShowS+data St = St {-# UNPACK #-} !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) ->+ -- | Update column position for a token+ (Token s -> Pos -> Pos) ->+ -- | 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)+ columnIncrement+ 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 (columnIncrement ch c))+ (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) ->+ -- | Update column position for a token+ (Token s -> Pos -> Pos) ->+ -- | 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)+ columnIncrement+ 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 (columnIncrement ch c) {-# 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 +724,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 +741,39 @@ '\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 w' = go 0+expandTab ::+ Pos ->+ String ->+ String+expandTab w' = go 0 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 !i 0 ('\t' : xs) = go i (w - (i `rem` w)) xs+ go !i 0 (x : xs) = x : go (i + 1) 0 xs+ go !i n xs = ' ' : go (i + 1) (n - 1) xs+ w = unPos w'++-- | Return updated column position that corresponds to the given 'Char'.+charInc :: Char -> Pos -> Pos+charInc ch c+ | Unicode.isZeroWidthChar ch = c+ | Unicode.isWideChar ch = c <> pos1 <> pos1+ | otherwise = c <> pos1++-- | Return updated column position that corresponds to the given 'Word8'.+byteInc :: Word8 -> Pos -> Pos+byteInc w c+ | w < 0x20 || (w >= 0x7f && w < 0xa0) = c -- C0 and C1 control chars+ | otherwise = c <> pos1
+ Text/Megaparsec/Unicode.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE Safe #-}++-- |+-- Module : Text.Megaparsec.Unicode+-- Copyright : © 2024–present Megaparsec contributors+-- License : FreeBSD+--+-- Maintainer : Mark Karpov <markkarpov92@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Utility functions for working with Unicode.+--+-- @since 9.7.0+module Text.Megaparsec.Unicode+ ( stringLength,+ charLength,+ isWideChar,+ isZeroWidthChar,+ )+where++import Data.Array (Array, bounds, listArray, (!))+import Data.Char (ord)++-- | Calculate length of a string taking into account the fact that certain+-- 'Char's may span more than 1 column.+--+-- @since 9.7.0+stringLength :: (Traversable t) => t Char -> Int+stringLength = sum . fmap charLength++-- | Return length of an individual 'Char'.+--+-- @since 9.7.0+charLength :: Char -> Int+charLength ch+ | isZeroWidthChar ch = 0+ | isWideChar ch = 2+ | otherwise = 1++-- | Determine whether the given 'Char' is “wide”, that is, whether it spans+-- 2 columns instead of one.+--+-- @since 9.7.0+isWideChar :: Char -> Bool+isWideChar c = go (bounds wideCharRanges)+ where+ go (lo, hi)+ | hi < lo = False+ | a <= n && n <= b = True+ | n < a = go (lo, pred mid)+ | otherwise = go (succ mid, hi)+ where+ mid = (lo + hi) `div` 2+ (a, b) = wideCharRanges ! mid+ n = ord c++-- | Determine whether the given 'Char' is "zero-width", that is, whether it+-- has no visible representation and does not advance the cursor position.+-- This includes control characters and certain Unicode zero-width characters.+--+-- @since 9.8.0+isZeroWidthChar :: Char -> Bool+isZeroWidthChar c = go (bounds zeroWidthCharRanges)+ where+ go (lo, hi)+ | hi < lo = False+ | a <= n && n <= b = True+ | n < a = go (lo, pred mid)+ | otherwise = go (succ mid, hi)+ where+ mid = (lo + hi) `div` 2+ (a, b) = zeroWidthCharRanges ! mid+ n = ord c++-- | Wide character ranges.+wideCharRanges :: Array Int (Int, Int)+wideCharRanges =+ listArray+ (0, 118)+ [ (0x001100, 0x00115f),+ (0x00231a, 0x00231b),+ (0x002329, 0x00232a),+ (0x0023e9, 0x0023ec),+ (0x0023f0, 0x0023f0),+ (0x0023f3, 0x0023f3),+ (0x0025fd, 0x0025fe),+ (0x002614, 0x002615),+ (0x002648, 0x002653),+ (0x00267f, 0x00267f),+ (0x002693, 0x002693),+ (0x0026a1, 0x0026a1),+ (0x0026aa, 0x0026ab),+ (0x0026bd, 0x0026be),+ (0x0026c4, 0x0026c5),+ (0x0026ce, 0x0026ce),+ (0x0026d4, 0x0026d4),+ (0x0026ea, 0x0026ea),+ (0x0026f2, 0x0026f3),+ (0x0026f5, 0x0026f5),+ (0x0026fa, 0x0026fa),+ (0x0026fd, 0x0026fd),+ (0x002705, 0x002705),+ (0x00270a, 0x00270b),+ (0x002728, 0x002728),+ (0x00274c, 0x00274c),+ (0x00274e, 0x00274e),+ (0x002753, 0x002755),+ (0x002757, 0x002757),+ (0x002795, 0x002797),+ (0x0027b0, 0x0027b0),+ (0x0027bf, 0x0027bf),+ (0x002b1b, 0x002b1c),+ (0x002b50, 0x002b50),+ (0x002b55, 0x002b55),+ (0x002e80, 0x002e99),+ (0x002e9b, 0x002ef3),+ (0x002f00, 0x002fd5),+ (0x002ff0, 0x002ffb),+ (0x003000, 0x00303e),+ (0x003041, 0x003096),+ (0x003099, 0x0030ff),+ (0x003105, 0x00312f),+ (0x003131, 0x00318e),+ (0x003190, 0x0031ba),+ (0x0031c0, 0x0031e3),+ (0x0031f0, 0x00321e),+ (0x003220, 0x003247),+ (0x003250, 0x004db5),+ (0x004e00, 0x009fef),+ (0x00a000, 0x00a48c),+ (0x00a490, 0x00a4c6),+ (0x00a960, 0x00a97c),+ (0x00ac00, 0x00d7a3),+ (0x00f900, 0x00fa6d),+ (0x00fa70, 0x00fad9),+ (0x00fe10, 0x00fe19),+ (0x00fe30, 0x00fe52),+ (0x00fe54, 0x00fe66),+ (0x00fe68, 0x00fe6b),+ (0x00ff01, 0x00ff60),+ (0x00ffe0, 0x00ffe6),+ (0x016fe0, 0x016fe3),+ (0x017000, 0x0187f7),+ (0x018800, 0x018af2),+ (0x01b000, 0x01b11e),+ (0x01b150, 0x01b152),+ (0x01b164, 0x01b167),+ (0x01b170, 0x01b2fb),+ (0x01f004, 0x01f004),+ (0x01f0cf, 0x01f0cf),+ (0x01f18e, 0x01f18e),+ (0x01f191, 0x01f19a),+ (0x01f200, 0x01f202),+ (0x01f210, 0x01f23b),+ (0x01f240, 0x01f248),+ (0x01f250, 0x01f251),+ (0x01f260, 0x01f265),+ (0x01f300, 0x01f320),+ (0x01f32d, 0x01f335),+ (0x01f337, 0x01f37c),+ (0x01f37e, 0x01f393),+ (0x01f3a0, 0x01f3ca),+ (0x01f3cf, 0x01f3d3),+ (0x01f3e0, 0x01f3f0),+ (0x01f3f4, 0x01f3f4),+ (0x01f3f8, 0x01f43e),+ (0x01f440, 0x01f440),+ (0x01f442, 0x01f4fc),+ (0x01f4ff, 0x01f53d),+ (0x01f54b, 0x01f54e),+ (0x01f550, 0x01f567),+ (0x01f57a, 0x01f57a),+ (0x01f595, 0x01f596),+ (0x01f5a4, 0x01f5a4),+ (0x01f5fb, 0x01f64f),+ (0x01f680, 0x01f6c5),+ (0x01f6cc, 0x01f6cc),+ (0x01f6d0, 0x01f6d2),+ (0x01f6d5, 0x01f6d5),+ (0x01f6eb, 0x01f6ec),+ (0x01f6f4, 0x01f6fa),+ (0x01f7e0, 0x01f7eb),+ (0x01f90d, 0x01f971),+ (0x01f973, 0x01f976),+ (0x01f97a, 0x01f9a2),+ (0x01f9a5, 0x01f9aa),+ (0x01f9ae, 0x01f9ca),+ (0x01f9cd, 0x01f9ff),+ (0x01fa70, 0x01fa73),+ (0x01fa78, 0x01fa7a),+ (0x01fa80, 0x01fa82),+ (0x01fa90, 0x01fa95),+ (0x020000, 0x02a6d6),+ (0x02a700, 0x02b734),+ (0x02b740, 0x02b81d),+ (0x02b820, 0x02cea1),+ (0x02ceb0, 0x02ebe0),+ (0x02f800, 0x02fa1d)+ ]+{-# NOINLINE wideCharRanges #-}++-- | Zero-width character ranges.+zeroWidthCharRanges :: Array Int (Int, Int)+zeroWidthCharRanges =+ listArray+ (0, 12)+ [ (0x0000, 0x001f), -- C0 control characters+ (0x007f, 0x009f), -- DEL and C1 control characters+ (0x00ad, 0x00ad), -- Soft Hyphen+ (0x0300, 0x036f), -- Combining Diacritical Marks+ (0x0483, 0x0489), -- Combining Cyrillic+ (0x0591, 0x05bd), -- Hebrew combining marks+ (0x05bf, 0x05bf), -- Hebrew point+ (0x05c1, 0x05c2), -- Hebrew points+ (0x05c4, 0x05c5), -- Hebrew marks+ (0x05c7, 0x05c7), -- Hebrew point+ (0x0610, 0x061a), -- Arabic combining marks+ (0x200b, 0x200f), -- Zero width chars and directional marks+ (0x202a, 0x202e) -- Directional formatting+ ]+{-# NOINLINE zeroWidthCharRanges #-}
bench/memory/Main.hs view
@@ -1,51 +1,51 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B 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 qualified Text.Megaparsec.Byte.Binary as Binary 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--#if !MIN_VERSION_base(4,13,0)-import Data.Semigroup ((<>))-#endif---- | The type of parser that consumes 'String's.+import Weigh +-- | The type of parser that consumes 'Text'. type Parser = Parsec Void Text +-- | The type of parser that consumes 'ByteString'.+type ParserBs = Parsec Void ByteString+ 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'))@@ -54,13 +54,15 @@ bparser "octal" mkInt (const (L.octal :: Parser Integer)) bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)) bparser "scientific" mkInt (const L.scientific)+ bparserBs "word32be" many0x33 (const $ many Binary.word32be)+ bparserBs "word32le" many0x33 (const $ many Binary.word32le) forM_ stdSeries $ \n -> bbundle "single error" n [n] 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 +75,153 @@ 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.+-- | Perform a series of measurements with the same parser.+bparserBs ::+ (NFData a) =>+ -- | Name of the benchmark group+ String ->+ -- | How to construct input+ (Int -> ByteString) ->+ -- | The parser receiving its future input+ ((ByteString, Int) -> ParserBs a) ->+ Weigh ()+bparserBs name f p = forM_ stdSeries $ \i -> do+ let arg = (f i, i)+ p' (s, n) = parse (p (s, n)) "" s+ func (name ++ "-" ++ show i) p' arg -bbundle- :: String -- ^ Name of the benchmark- -> Int -- ^ Number of lines in input stream- -> [Int] -- ^ Lines with parse errors- -> Weigh ()+-- | Benchmark the 'errorBundlePretty' function.+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---- | Bench the 'reachOffset' function.+ func+ ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+ errorBundlePretty+ bundle -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)+-- | Benchmark the 'reachOffset' function.+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 = ""- }---- | Bench the 'reachOffsetNoLine' function.+ snd $+ reachOffset+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -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)+-- | Benchmark the 'reachOffsetNoLine' function.+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.+-- | Like 'manyAs' but the result is a 'ByteString'.+many0x33 :: Int -> ByteString+many0x33 n = B.replicate n 0x33 +-- | 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,191 +1,221 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Criterion.Main+import Data.ByteString (ByteString)+import qualified Data.ByteString as B 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 qualified Text.Megaparsec.Byte.Binary as Binary 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)-import Data.Semigroup ((<>))-#endif---- | The type of parser that consumes 'String's.-+-- | The type of parser that consumes 'Text'. 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+-- | The type of parser that consumes 'ByteString'.+type ParserBs = Parsec Void ByteString - ]+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),+ bparserBs "word32be" many0x33 (const $ many Binary.word32be),+ bparserBs "word32le" many0x33 (const $ many Binary.word32le),+ 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.+-- | Perform a series to measurements with the same parser.+bparserBs ::+ (NFData a) =>+ -- | Name of the benchmark group+ String ->+ -- | How to construct input+ (Int -> ByteString) ->+ -- | The parser receiving its future input+ ((ByteString, Int) -> ParserBs a) ->+ -- | The benchmark+ Benchmark+bparserBs 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 -bbundle- :: String -- ^ Name of the benchmark- -> Int -- ^ Number of lines in input stream- -> [Int] -- ^ Lines with parse errors- -> Benchmark+-- | Benchmark the 'errorBundlePretty' function.+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)---- | Bench the 'reachOffset' function.+ in bench+ ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+ (nf errorBundlePretty bundle) -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))+-- | Benchmark the 'reachOffset' function.+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 = ""- }---- | Bench the 'reachOffsetNoLine' function.+ snd $+ reachOffset+ targetOffset+ PosState+ { pstateInput = manyAs (targetOffset - startOffset),+ pstateOffset = startOffset,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } -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))+-- | Benchmark the 'reachOffsetNoLine' function.+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.+-- | Like 'manyAs' but the result is a 'ByteString'.+many0x33 :: Int -> ByteString+many0x33 n = B.replicate n 0x33 +-- | 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,127 @@-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: 2.4+name: megaparsec+version: 9.8.1+license: BSD-2-Clause+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-description:+tested-with:+ ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1 - 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.+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. -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.Binary+ 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.State+ Text.Megaparsec.Stream+ Text.Megaparsec.Unicode + other-modules:+ Text.Megaparsec.Class+ Text.Megaparsec.Common+ Text.Megaparsec.Lexer++ default-language: Haskell2010+ build-depends:+ array >=0.5.3 && <0.6,+ base >=4.18 && <5,+ bytestring >=0.2 && <0.13,+ case-insensitive >=1.2 && <1.3,+ containers >=0.5 && <0.9,+ deepseq >=1.3 && <1.6,+ mtl >=2.2.2 && <3,+ parser-combinators >=1.0 && <2,+ scientific >=0.3.7 && <0.4,+ text >=0.2 && <2.2,+ transformers >=0.4 && <0.7++ if flag(dev)+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages++ else+ ghc-options: -O2 -Wall++ if impl(ghc >=9.8)+ ghc-options: -Wno-x-partial+ 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.18 && <5,+ bytestring >=0.2 && <0.13,+ containers >=0.5 && <0.9,+ criterion >=0.6.2.1 && <1.7,+ deepseq >=1.3 && <1.6,+ megaparsec,+ text >=0.2 && <2.2 + if flag(dev)+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages++ 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.18 && <5,+ bytestring >=0.2 && <0.13,+ containers >=0.5 && <0.9,+ deepseq >=1.3 && <1.6,+ megaparsec,+ text >=0.2 && <2.2,+ weigh >=0.0.4++ if flag(dev)+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages++ else+ ghc-options: -O2 -Wall