packages feed

megaparsec 6.5.0 → 9.8.1

raw patch · 45 files changed

Files

− AUTHORS.md 
@@ -1,54 +0,0 @@-# Authors--The following people have contributed to Megaparsec/Parsec library. Due to-the fact that original Parsec project has not been keeping this sort of-file, many contributors are missing from this list, if you've contributed to-Parsec project in the past, please open an issue or a pull request, so we-can add you to this list.--Names below are sorted alphabetically.--## Author of original Parsec library--* Daan Leijen--## Maintainer--* Mark Karpov--## Retired maintainers--* Antoine Latter-* Derek Elkins--## Contributors--* Albert Netymk-* Alex Washburn (@recursion-ninja)-* Antoine Latter-* Artyom (@neongreen)-* Auke Booij-* Ben Pence-* Benjamin Kästner-* Björn Buckwalter-* Bryan O'Sullivan-* Cies Breijs-* Daniel Díaz-* Daniel Gorín-* Dennis Gosnell-* Derek Elkins-* Emil Sköldberg-* Herbert Valerio Riedel-* Joel Williamson-* Mark Karpov-* Paolo Martini-* redneb-* Reto Kramer-* Rogan Creswick-* Roman Cheplyaka-* Ryan Scott-* Simon Vandel-* Slava Shklyaev-* Tal Walter-* Tomáš Janoušek-* Vladislav Zavialov
CHANGELOG.md view
@@ -1,3 +1,359 @@+*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+  parse errors at a given offset without manipulating parser state manually.++* Megaparsec now supports registration of “delayed” parse errors. On lower+  level we added a new field called `stateParseErrors` to the `State`+  record. The type also had to change from `State s` to `State s e`. This+  field contains the list of registered `ParseErrors` that do not end+  parsing immediately but still will cause failure in the end if the list is+  not empty. Users are expected to register parse errors using the three+  functions: `registerParseError`, `registerFailure`, and+  `registerFancyFailure`. These functions are analogous to those without the+  `register` prefix, except that they have “delayed” effect.++* Added the `tokensLength` method to the `Stream` type class to improve+  support for custom input streams.++* Added the `setErrorOffset` function to set offset of `ParseError`s.++* Changed type signatures of `reachOffset` and `reachOffsetNoLine` methods+  of the `Stream` type class. Instead of three-tuple `reachOffset` now+  returns two-tuple because `SourcePos` is already contained in the returned+  `PosState` record.++* Generalized `decimal`, `binary`, `octal`, and `hexadecimal` parsers in+  lexer modules so that they `Num` instead of just `Integral`.++* Dropped support for GHC 8.2.x and older.++## Megaparsec 7.0.5++* Dropped support for GHC 7.10.++* Adapted the code to `MonadFail` changes in `base-4.13`.++* Separated the test suite into its own package. The reason is that we can+  avoid circular dependency on `hspec-megaparsec` and thus avoid keeping+  copies of its source files in our test suite, as we had to do before.+  Another benefit is that we can export some auxiliary functions in+  `megaparsec-tests` which can be used by other test suites, for example in+  the `parser-combinators-tests` package.++  Version of `megaparsec-tests` will be kept in sync with versions of+  `megaparsec` from now on.++## Megaparsec 7.0.4++* Numerous documentation corrections.++## Megaparsec 7.0.3++* Fixed the build with `mtl` older than `2.2.2`.++## Megaparsec 7.0.2++* Fixed the property test for `char'` which was failing in the case when+  there is a character with different upper and title cases.++* More descriptive error messages when `elabel` or `ulabel` from+  `Text.Megaparsec.Error.Builder` are used with empty strings.++* Typo fixes in the docs.++## Megaparsec 7.0.1++* Fixed a bug in `errorBundlePretty`. Previously the question sign `?` was+  erroneously inserted before offending line in 2nd and later parse errors.++## Megaparsec 7.0.0++### General++* Dropped the `Text.Megaparsec.Perm` module. Use+  `Control.Applicative.Permutations` from `parser-combinators` instead.++* Dropped the `Text.Megaparsec.Expr` module. Use+  `Control.Monad.Combinators.Expr` from `parser-combinators` instead.++* The debugging function `dbg` has been moved from `Text.Megaparsec` to its+  own module `Text.Megaparsec.Debug`.++* Dropped support for GHC 7.8.++### Combinators++* Moved some general combinators from `Text.Megaparsec.Char` and+  `Text.Megaparsec.Byte` to `Text.Megaparsec`, renaming some of them for+  clarity.++  Practical consequences:++  * Now there is the `single` combinator that is a generalization of `char`+    for arbitrary streams. `Text.Megaparsec.Char` and `Text.Megaparsec.Byte`+    still contain `char` as type-constrained versions of `single`.++  * Similarly, now there is the `chunk` combinator that is a generalization+    of `string` for arbitrary streams. The `string` combinator is still+    re-exported from `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` for+    compatibility.++  * `satisfy` does not depend on type of token, and so it now lives in+    `Text.Megaparsec`.++  * `anyChar` was renamed to `anySingle` and moved to `Text.Megaparsec`.++  * `notChar` was renamed to `anySingleBut` and moved to `Text.Megaparsec`.++  * `oneOf` and `noneOf` were moved to `Text.Megaparsec`.++* Simplified the type of the `token` primitive. It now takes just a matching+  function `Token s -> Maybe a` as the first argument and the collection of+  expected items `Set (ErrorItem (Token s))` as the second argument. This+  makes sense because the collection of expected items cannot depend on what+  we see in the input stream.++* The `label` primitive now doesn't prepend the phrase “the rest of” to the+  label when its inner parser produces hints after consuming input. In that+  case `label` has no effect.++* Fixed the `Text.Megaparsec.Char.Lexer.charLiteral` so it can accept longer+  escape sequences (max length is now 10).++* Added the `binDigitChar` functions in `Text.Megaparsec.Byte` and+  `Text.Megaparsec.Char`.++* Added the `binary` functions in `Text.Megaparsec.Byte.Lexer` and+  `Text.Megaparsec.Char.Lexer`.++* Improved case-insensitive character matching in the cases when e.g.+  `isLower` and `isUpper` both return `False`. Functions affected:+  `Text.Megaparsec.Char.char'`.++* Renamed `getPosition` to `getSourcePos`.++* Renamed `getTokensProcessed` to `getOffset`, `setTokensProcessed` to+  `setOffset`.++* Dropped `getTabWidth` and `setTabWidth` because tab width is irrelevant to+  parsing process now, it's only relevant for pretty-printing of parse+  errors, which is handled separately.++* Added and `withParsecT` in `Text.Megaparsec.Internal` to allow changing+  the type of the custom data component in parse errors.++### Parser state and input stream++* Dropped stacks of source positions. Accordingly, the functions+  `pushPosition` and `popPosition` from `Text.Megaparsec` and+  `sourcePosStackPretty` from `Text.Megaparsec.Error` were removed. The+  reason for this simplification is that I could not find any code that uses+  the feature and it makes manipulation of source positions hairy.++* Introduced `PosState` for calculating `SourcePos` from offsets and getting+  offending line for displaying on pretty-printing of parse errors. It's now+  contained in both `State` and `ParseErrorBundle`.++* Dropped `positionAt1`, `positionAtN`, `advance1`, and `advanceN` methods+  from `Stream`. They are no longer necessary because `reachOffset` (and its+  specialized version `reachOffsetNoLine`) takes care of `SourcePos`+  calculation.++### Parse errors++* `ParseError` now contains raw offset in input stream instead of+  `SourcePos`. `errorPos` was dropped from `Text.Megaparsec.Error`.++* `ParseError` is now parametrized over stream type `s` instead of token+  type `t`.++* Introduced `ParseErrorBundle` which contains one or more `ParseError`+  equipped with all information that is necessary to pretty-print them+  together with offending lines from the input stream. Functions like+  `runParser` now return `ParseErrorBundle` instead of plain `ParseError`.++  By default there will be only one `ParseError` in such a bundle, but it's+  possible to add more parse errors to a bundle manually. During+  pretty-printing, the input stream will be traversed only once.++* The primary function for pretty-printing of parse+  errors—`errorBundlePretty` always prints offending lines now.+  `parseErrorPretty` is still there, but it probably won't see a lot of use+  from now on. `parseErrorPretty'` and `parseErrorPretty_` were removed.+  `parseTest'` was removed because `parseTest` always prints offending lines+  now.++* Added `attachSourcePos` function in `Text.Megaparsec.Error`.++* The `ShowToken` type class has been removed and its method `showTokens`+  now lives in the `Stream` type class.++* The `LineToken` type class is no longer necessary because the new method+  `reachOffset` of the type class `Stream` does its job.++* In `Text.Megaparsec.Error` the following functions were added:+  `mapParseError`, `errorOffset`.++* Implemented continuous highlighting in parse errors. For this we added the+  `errorComponentLen` method to the `ShowErrorComponent` type class.++### Parse error builder++* The functions `err` and `errFancy` now accept offsets at which the parse+  errors are expected to have happened, i.e. `Int`s. Thus `posI` and `posN`+  are no longer necessary and were removed.++* `ET` is now parametrized over the type of stream `s` instead of token type+  `t`.++* Combinators like `utoks` and `etoks` now accept chunks of input stream+  directly, i.e. `Tokens s` instead of `[Token s]` which should be more+  natural and convenient.+ ## Megaparsec 6.5.0  * Added `Text.Megaparsec.Internal`, which exposes some internal data@@ -93,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. @@ -186,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@@ -608,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
LICENSE.md view
@@ -1,5 +1,5 @@-Copyright © 2015–2018 Megaparsec contributors<br>-Copyright © 2007 Paolo Martini<br>+Copyright © 2015–present Megaparsec contributors\+Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen  All rights reserved.
README.md view
@@ -4,15 +4,13 @@ [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec)-[![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec)+[![CI](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml)  * [Features](#features)     * [Core features](#core-features)     * [Error messages](#error-messages)-    * [Alex support](#alex-support)+    * [External lexers](#external-lexers)     * [Character and binary parsing](#character-and-binary-parsing)-    * [Permutation parsing](#permutation-parsing)-    * [Expression parsing](#expression-parsing)     * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials)@@ -25,12 +23,11 @@ * [Related packages](#related-packages) * [Prominent projects that use Megaparsec](#prominent-projects-that-use-megaparsec) * [Links to announcements and blog posts](#links-to-announcements-and-blog-posts)-* [Authors](#authors) * [Contribution](#contribution) * [License](#license)  This is an industrial-strength monadic parser combinator library. Megaparsec-is a feature-rich package that strikes a nice balance between speed,+is a feature-rich package that tries to find a nice balance between speed, flexibility, and quality of parse errors.  ## Features@@ -42,157 +39,135 @@ ### Core features  The package is built around `MonadParsec`, an MTL-style monad transformer.-All tools and features work with all instances of `MonadParsec`. You can-achieve various effects combining monad transformers, i.e. building a-monadic stack. Since the common monad transformers like `WriterT`, `StateT`,-`ReaderT` and others are instances of the `MonadParsec` type class, you can-wrap `ParsecT` *in* these monads, achieving, for example, backtracking-state.+Most features work with all instances of `MonadParsec`. One can achieve+various effects combining monad transformers, i.e. building a monadic stack.+Since the common monad transformers like `WriterT`, `StateT`, `ReaderT` and+others are instances of the `MonadParsec` type class, one can also wrap+`ParsecT` *in* these monads, achieving, for example, backtracking state.  On the other hand `ParsecT` is an instance of many type classes as well. The most useful ones are `Monad`, `Applicative`, `Alternative`, and `MonadParsec`. -Megaparsec includes all functionality that is available in Parsec plus-features some combinators that are missing in other parsing libraries:+Megaparsec includes all functionality that is typically available in+Parsec-like libraries and also features some special combinators: -* `failure` allows to fail reporting a parse error with unexpected and-  expected items.-* `fancyFailure` allows to fail reporting custom error messages.-* `withRecovery` allows to recover from parse errors “on-the-fly” and+* `parseError` allows us to end parsing and report an arbitrary parse error.+* `withRecovery` can be used to recover from parse errors “on-the-fly” and   continue parsing. Once parsing is finished, several parse errors may be   reported or ignored altogether.-* `observing` allows to “observe” parse errors without ending parsing (they-  are returned in `Left`, while normal results are wrapped in `Right`).+* `observing` makes it possible to “observe” parse errors without ending+  parsing. -In addition to that, Megaparsec 6 features high-performance combinators-similar to those found in Attoparsec:+In addition to that, Megaparsec features high-performance combinators+similar to those found in [Attoparsec][attoparsec]:  * `tokens` makes it easy to parse several tokens in a row (`string` and   `string'` are built on top of this primitive). This is about 100 times   faster than matching a string token by token. `tokens` returns “chunk” of   original input, meaning that if you parse `Text`, it'll return `Text`-  without any repacking.+  without repacking. * `takeWhile` and `takeWhile1` are about 150 times faster than approaches   involving `many`, `manyTill` and other similar combinators.-* `takeP` allows to grab n tokens from the stream and returns them as a+* `takeP` allows us to grab n tokens from the stream and returns them as a   “chunk” of the stream. -So now that we have matched the main “performance boosters” of Attoparsec,-Megaparsec 6 is not significantly slower than Attoparsec if you write your-parser carefully (see also [the section about performance](#performance)).+Megaparsec is about as fast as Attoparsec if you write your parser carefully+(see also [the section about performance](#performance)). -Megaparsec can currently work with the following types of input stream+The library can currently work with the following types of input stream out-of-the-box: -* `String` = `[Char]`+* `String = [Char]` * `ByteString` (strict and lazy) * `Text` (strict and lazy) -It's also simple to make it work with custom token streams, and Megaparsec-users have done so many times.+It's also possible to make it work with custom token streams by making them+an instance of the `Stream` type class.  ### Error messages -Megaparsec 5 introduced well-typed error messages and the ability to use-custom data types to adjust the library to specific domain of interest. No-need to use a shapeless bunch of strings.+* Megaparsec has typed error messages and the ability to signal custom parse+  errors that better suit the user's domain of interest. -The design of parse errors has been revised in version 6 significantly, but-custom errors are still easy (probably even easier now).+* 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. -### Alex support+* Instead of a single parse error Megaparsec produces so-called+  `ParseErrorBundle` data type that helps to manage multi-error messages and+  pretty-print them. Since version 8, reporting multiple parse errors at+  once has become easier. +### External lexers+ Megaparsec works well with streams of tokens produced by tools like Alex.-The design of the `Stream` type class has been changed significantly in-version 6, but user can still work with custom streams of tokens without-problems.+The design of the `Stream` type class has been changed significantly in the+recent versions, but user can still work with custom streams of tokens.  ### Character and binary parsing  Megaparsec has decent support for Unicode-aware character parsing. Functions-for character parsing live in the-[`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html)-module. Similarly, there is-[`Text.Megaparsec.Byte`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte.html)-module for parsing streams of bytes.--### Permutation parsing--For those who are interested in parsing of permutation phrases, there is-[`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html).-You have to import the module explicitly, it's not included in the-`Text.Megaparsec` module.--### Expression parsing--Megaparsec has a solution for parsing of expressions. Take a look at-[`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html).-You have to import the module explicitly, it's not included in the-`Text.Megaparsec`.--Given a table of operators that describes their fixity and precedence, you-can construct a parser that will parse any expression involving the-operators. See documentation for comprehensive description of how it works.+for character parsing live in the [`Text.Megaparsec.Char`][tm-char] module.+Similarly, there is [`Text.Megaparsec.Byte`][tm-byte] module for parsing+streams of bytes.  ### Lexer -[`Text.Megaparsec.Char.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char-Lexer.html)-is a module that should help you write your lexer. If you have used `Parsec`-in the past, this module “fixes” its particularly inflexible-`Text.Parsec.Token`.--`Text.Megaparsec.Char.Lexer` is intended to be imported using a qualified-import, it's not included in `Text.Megaparsec`. The module doesn't impose-how you should write your parser, but certain approaches may be more elegant-than others. An especially important theme is parsing of white space,-comments, and indentation.+[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is a module that should help+you write your lexer. If you have used `Parsec` in the past, this module+“fixes” its particularly inflexible `Text.Parsec.Token`. -The design of the module allows you quickly solve simple tasks and doesn't-get in your way when you want to implement something less standard.+[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is intended to be imported+using a qualified import, it's not included in [`Text.Megaparsec`][tm]. The+module doesn't impose how you should write your parser, but certain+approaches may be more elegant than others. An especially important theme is+parsing of white space, comments, and indentation. -Since Megaparsec 5, all tools for indentation-sensitive parsing are-available in `Text.Megaparsec.Char.Lexer` module—no third party packages-required.+The design of the module allows one quickly solve simple tasks and doesn't+get in the way when the need to implement something less standard arises. -`Text.Megaparsec.Byte.Lexer` is also available for users who wish to parse-binary data.+[`Text.Megaparsec.Byte.Lexer`][tm-byte-lexer] is also available for users+who wish to parse binary data.  ## Documentation  Megaparsec is well-documented. See the [current version of Megaparsec-documentation on Hackage](https://hackage.haskell.org/package/megaparsec).+documentation on Hackage][hackage].  ## Tutorials -You can find Megaparsec tutorials-[here](https://markkarpov.com/learn-haskell.html#megaparsec-tutorials). They-should provide sufficient guidance to help you to start with your parsing-tasks. The site also has instructions and tips for Parsec users who decide-to migrate to Megaparsec.+You can find the most complete Megaparsec tutorial [here][the-tutorial]. It+should provide sufficient guidance to help you start with your parsing+tasks.  ## Performance -Despite being flexible, Megaparsec is also quite fast. Here is how-Megaparsec 6.4.0 compares to Attoparsec 0.13.2.0 (the fastest widely used-parsing library in the Haskell ecosystem):+Despite being flexible, Megaparsec is also fast. Here is how Megaparsec+compares to [Attoparsec][attoparsec] (the fastest widely used parsing+library in the Haskell ecosystem):  Test case         | Execution time | Allocated | Max residency ------------------|---------------:|----------:|-------------:-CSV (Attoparsec)  |       57.14 μs |   397,912 |        10,560-CSV (Megaparsec)  |       76.27 μs |   557,272 |         9,120-Log (Attoparsec)  |       244.2 μs | 1,181,120 |        11,144-Log (Megaparsec)  |       315.2 μs | 1,485,776 |        11,392-JSON (Attoparsec) |       14.39 μs |   132,496 |         9,048-JSON (Megaparsec) |       26.70 μs |   233,336 |         9,424+CSV (Attoparsec)  |       76.50 μs |   397,784 |        10,544+CSV (Megaparsec)  |       64.69 μs |   352,408 |         9,104+Log (Attoparsec)  |       302.8 μs | 1,150,032 |        10,912+Log (Megaparsec)  |       337.8 μs | 1,246,496 |        10,912+JSON (Attoparsec) |       18.20 μs |   128,368 |         9,032+JSON (Megaparsec) |       25.45 μs |   203,824 |         9,176 -The benchmarks were created to guide development of Megaparsec 6 and can be-found [here](https://github.com/mrkkrp/parsers-bench).+You can run the benchmarks yourself by executing: -If you think your Megaparsec parser is not efficient enough, take a look at-[these-instructions](https://markkarpov.com/megaparsec/writing-a-fast-parser.html).+```+$ nix-build -A benches.parsers-bench+$ cd result/bench+$ ./bench-memory+$ ./bench-speed+``` +More information about benchmarking and development can be found+[here][hacking].+ ## Comparison with other solutions  There are quite a few libraries that can be used for parsing in Haskell,@@ -200,129 +175,94 @@  ### Megaparsec vs Attoparsec -[Attoparsec](https://github.com/bos/attoparsec) is another prominent Haskell-library for parsing. Although the both libraries deal with parsing, it's-usually easy to decide which you will need in particular project:+[Attoparsec][attoparsec] is another prominent Haskell library for parsing.+Although both libraries deal with parsing, it's usually easy to decide which+you will need in particular project: -* *Attoparsec* is faster but not that feature-rich. It should be used when-  you want to process large amounts of data where performance matters more-  than quality of error messages.+* *Attoparsec* is sometimes faster but not that feature-rich. It should be+  used when you want to process large amounts of data where performance+  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-usually not huge, just go with Megaparsec, otherwise Attoparsec may be a-better choice.--Since version 6, Megaparsec features the same fast primitives that-Attoparsec has, so in many cases the difference in speed is not that big.-Megaparsec now aims to be “one size fits all” ultimate solution to parsing,-so it can be used even to parse low-level binary formats.+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 -Since Megaparsec is a fork of Parsec, we are bound to list the main-differences between the two libraries:+Since Megaparsec is a fork of [Parsec][parsec], we are bound to list the+main differences between the two libraries: -* Better error messages. We test our error messages using numerous-  QuickCheck (generative) tests. Good error messages are just as important-  for us as correct return values of our parsers. Megaparsec will be-  especially useful if you write a compiler or an interpreter for some-  language.+* Better error messages. Megaparsec has typed error messages and custom+  error messages, it can also report multiple parse errors at once. -* Megaparsec 6 can show the line on which parse error happened as part of+* Megaparsec can show the line on which parse error happened as part of   parse error. This makes it a lot easier to figure out where the error   happened. -* Some quirks and “buggy features” (as well as plain bugs) of original-  Parsec are fixed. There is no undocumented surprising stuff in Megaparsec.+* Some quirks and bugs of Parsec are fixed. -* Better support for Unicode parsing in `Text.Megaparsec.Char`.+* 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.--* Comprehensive test suite covering nearly 100% of our code. Compare that to-  absence--* We have benchmarks to detect performance regressions.--* Better documentation, with 100% of functions covered, without typos and-  obsolete information, with working examples. Megaparsec's documentation is-  well-structured and doesn't contain things useless to end users.--* Megaparsec's code is clearer and doesn't contain “magic” found in original-  Parsec.+  indentation matters. -* Megaparsec has well-typed error messages and custom error messages.+* Better documentation.  * Megaparsec can recover from parse errors “on the fly” and continue   parsing. -* Megaparsec allows 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. This is not possible with Parsec.+* 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 on top of `tokens`,-  `takeWhileP`, `takeWhile1P`, `takeP` like Attoparsec.+* Megaparsec is faster and supports efficient operations `tokens`,+  `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec.  If you want to see a detailed change log, `CHANGELOG.md` may be helpful.-Also see [this original announcement](https://notehub.org/w7037) for another+Also see [this original announcement][original-announcement] for another comparison.  ### Megaparsec vs Trifecta -[Trifecta](https://hackage.haskell.org/package/trifecta) is another Haskell-library featuring good error messages. It's probably good, but also-under-documented, and has unfixed [bugs and-flaws](https://github.com/ekmett/trifecta/issues). Other reasons one may-question choice of Trifecta is his/her parsing library:+[Trifecta][trifecta] is another Haskell library featuring good error+messages. These are the common reasons why Trifecta may be problematic to+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`. -* Trifecta's error messages may be different with their own features, but-  certainly not as flexible as Megaparsec's error messages in the latest-  versions.--* Depends on `lens`. This means you'll pull in half of Hackage as transitive-  dependencies. Also if you're not into `lens` and would like to keep your-  code “vanilla”, you may not like the API.+* Depends on `lens`, which is a very heavy dependency. If you're not into+  `lens`, you may not like the API. -[Idris](https://www.idris-lang.org/) has recently switched from Trifecta to-Megaparsec which allowed it to [have better error messages and fewer-dependencies](https://twitter.com/edwinbrady/status/950084043282010117?s=09).+[Idris][idris] has switched from Trifecta to Megaparsec which allowed it to+[have better error messages and fewer dependencies][idris-testimony].  ### Megaparsec vs Earley -[Earley](https://hackage.haskell.org/package/Earley) is a newer library that-allows to safely (it your code compiles, then it probably works) parse+[Earley][earley] is a newer library that allows us to safely parse context-free grammars (CFG). Megaparsec is a lower-level library compared to-Earley, but there are still enough reasons to choose it over Earley:+Earley, but there are still enough reasons to choose it:  * Megaparsec is faster.  * Your grammar may be not context-free or you may want introduce some sort   of state to the parsing process. Almost all non-trivial parsers require-  something of this sort. Even if your grammar is context-free, state may-  allow to add some additional niceties. Earley does not support that.+  state. Even if your grammar is context-free, state may allow for+  additional niceties. Earley does not support that.  * Megaparsec's error messages are more flexible allowing to include   arbitrary data in them, return multiple error messages, mark regions that   affect any error that happens in those regions, etc. -* The approach Earley uses differs from the conventional monadic parsing. If-  you work not alone, people you work with, especially beginners, will be-  much more productive with libraries taking more traditional path to-  parsing like Megaparsec.--IOW, Megaparsec is less safe but also more powerful.+In other words, Megaparsec is less safe but also more powerful.  ## Related packages @@ -332,6 +272,8 @@ * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities   for testing Megaparsec parsers with with   [Hspec](https://hackage.haskell.org/package/hspec).+* [`replace-megaparsec`](https://hackage.haskell.org/package/replace-megaparsec)—Stream+  editing and find-and-replace with Megaparsec. * [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec)—Megaparsec   parser of CSV files that plays nicely with   [Cassava](https://hackage.haskell.org/package/cassava).@@ -339,53 +281,72 @@   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 -The following are some prominent projects that use Megaparsec:+Some prominent projects that use Megaparsec:  * [Idris](https://github.com/idris-lang/Idris-dev)—a general-purpose   functional programming language with dependent types+* [Dhall](https://github.com/dhall-lang/dhall-haskell)—an advanced+  configuration language+* [hnix](https://github.com/haskell-nix/hnix)—re-implementation of the Nix+  language in Haskell * [Hledger](https://github.com/simonmichael/hledger)—an accounting tool * [MMark](https://github.com/mmark-md/mmark)—strict markdown processor for   writers-* [Stache](https://github.com/stackbuilders/stache)—Mustache templates for-  Haskell-* [Language Puppet](https://github.com/bartavelle/language-puppet)—library-  for manipulating Puppet manifests  ## Links to announcements and blog posts  Here are some blog posts mainly announcing new features of the project and describing what sort of things are now possible: +* [Megaparsec 8](https://markkarpov.com/post/megaparsec-8.html)+* [Megaparsec 7](https://markkarpov.com/post/megaparsec-7.html) * [Evolution of error messages](https://markkarpov.com/post/evolution-of-error-messages.html) * [A major upgrade to Megaparsec: more speed, more power](https://markkarpov.com/post/megaparsec-more-speed-more-power.html) * [Latest additions to Megaparsec](https://markkarpov.com/post/latest-additions-to-megaparsec.html) * [Announcing Megaparsec 5](https://markkarpov.com/post/announcing-megaparsec-5.html) * [Megaparsec 4 and 5](https://markkarpov.com/post/megaparsec-4-and-5.html)-* [The original Megaparsec 4.0.0 announcement](https://notehub.org/w7037)--## Authors--The project was started and is currently maintained by Mark Karpov. You can-find the complete list of contributors in the `AUTHORS.md` file in the-official repository of the project. Thanks to all the people who propose-features and ideas, although they are not in `AUTHORS.md`, without them-Megaparsec would not be that good.+* [The original Megaparsec 4.0.0 announcement][original-announcement]  ## Contribution  Issues (bugs, feature requests or otherwise feedback) may be reported in-[the GitHub issue tracker for this project](https://github.com/mrkkrp/megaparsec/issues).+[the GitHub issue tracker for this+project](https://github.com/mrkkrp/megaparsec/issues). -Pull requests are also welcome (and yes, they will get attention and will be-merged quickly if they are good).+Pull requests are also welcome. If you would like to contribute to the+project, you may find [this document][hacking] helpful.  ## License -Copyright © 2015–2018 Megaparsec contributors\+Copyright © 2015–present Megaparsec contributors\ Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen  Distributed under FreeBSD license.++[hackage]: https://hackage.haskell.org/package/megaparsec+[the-tutorial]: https://markkarpov.com/tutorial/megaparsec.html+[hacking]: ./HACKING.md++[tm]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec.html+[tm-char]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html+[tm-byte]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte.html+[tm-char-lexer]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char-Lexer.html+[tm-byte-lexer]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte-Lexer.html++[attoparsec]: https://hackage.haskell.org/package/attoparsec+[parsec]: https://hackage.haskell.org/package/parsec+[trifecta]: https://hackage.haskell.org/package/trifecta+[earley]: https://hackage.haskell.org/package/Earley+[idris]: https://www.idris-lang.org/+[idris-testimony]: https://twitter.com/edwinbrady/status/950084043282010117?s=09++[parsers-bench]: https://github.com/mrkkrp/parsers-bench+[fast-parser]: https://markkarpov.com/megaparsec/writing-a-fast-parser.html+[original-announcement]: https://mail.haskell.org/pipermail/haskell-cafe/2015-September/121530.html
− Setup.hs 
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
Text/Megaparsec.hs view
@@ -1,6 +1,15 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module      :  Text.Megaparsec--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -11,10 +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. --@@ -24,125 +33,113 @@ -- > type Parser = Parsec Void Text -- >                      ^    ^ -- >                      |    |--- > Custom error component    Type of input+-- > Custom error component    Input stream type ----- Then you can write type signatures like @Parser Int@—for a parser that+-- Then you can write type signatures like @Parser 'Int'@—for a parser that -- returns an 'Int' for example. -- -- Similarly (since it's known to cause confusion), you should use--- 'ParseError' type parametrized like this:------ > ParseError Char Void--- >            ^    ^--- >            |    |--- >   Token type    Custom error component (the same you used in Parser)+-- 'ParseErrorBundle' type parametrized like this: ----- Token type for 'String' and 'Data.Text.Text' (strict and lazy) is 'Char',--- for 'Data.ByteString.ByteString's it's 'Data.Word.Word8'.+-- > ParseErrorBundle Text Void+-- >                  ^    ^+-- >                  |    |+-- >  Input stream type    Custom error component (the same you used in Parser) -- -- Megaparsec uses some type-level machinery to provide flexibility without -- compromising on type safety. Thus type signatures are sometimes necessary--- to avoid ambiguous types. If you're seeing a error message that reads+-- to avoid ambiguous types. If you're seeing an error message that reads -- 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.------ Megaparsec is capable of a lot. Apart from this standard functionality--- you can parse permutation phrases with "Text.Megaparsec.Perm",--- expressions with "Text.Megaparsec.Expr", do lexing with--- "Text.Megaparsec.Char.Lexer" and "Text.Megaparsec.Byte.Lexer". These--- modules should be imported explicitly along with the modules mentioned--- above.--{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-}-{-# 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 (..)-  , Parsec-  , ParsecT+    State (..),+    PosState (..),+    Parsec,+    ParsecT,+     -- * Running parser-  , parse-  , parseMaybe-  , parseTest-  , 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,+     -- * Derivatives of primitive combinators-  , (<?>)-  , unexpected-  , customFailure-  , match-  , region-  , takeRest-  , atEnd+    single,+    satisfy,+    anySingle,+    anySingleBut,+    oneOf,+    noneOf,+    chunk,+    (<?>),+    match,+    takeRest,+    atEnd,+     -- * Parser state combinators-  , getInput-  , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , setParserState-    -- * Debugging-  , dbg )+    getInput,+    setInput,+    getSourcePos,+    getOffset,+    setOffset,+    setParserState,+  ) where -import Control.Monad 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.Proxy-import Debug.Trace+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 -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif- -- $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@@ -151,36 +148,46 @@ -- This module is intended to be imported qualified: -- -- > import qualified Control.Monad.Combinators.NonEmpty as NE+--+-- Other modules of interest are:+--+--     * "Control.Monad.Combinators.Expr" for parsing of expressions.+--     * "Control.Applicative.Permutations" for parsing of permutations+--       phrases.  ---------------------------------------------------------------------------- -- Data types  -- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' -- monad transformer.- type Parsec e s = ParsecT e s Identity  ---------------------------------------------------------------------------- -- Running a parser --- | @'parse' p file input@ runs parser @p@ over 'Identity' (see 'runParserT'--- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a--- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a--- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn--- 'ParseError' into the string representation of the error message. See--- "Text.Megaparsec.Error" if you need to do more advanced error analysis.+-- | @'parse' p file input@ runs parser @p@ over 'Identity' (see+-- 'runParserT' if you're using the 'ParsecT' monad transformer; 'parse'+-- itself is just a synonym for 'runParser'). It returns either a+-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right').+-- 'errorBundlePretty' can be used to turn 'ParseErrorBundle' into the+-- string representation of the error message. See "Text.Megaparsec.Error"+-- if you need to do more advanced error analysis. ----- > main = case (parse numbers "" "11,2,43") of--- >          Left err -> putStr (parseErrorPretty err)+-- > main = case parse numbers "" "11,2,43" of+-- >          Left bundle -> putStr (errorBundlePretty bundle) -- >          Right xs -> print (sum xs) -- >--- > numbers = integer `sepBy` char ','--parse-  :: Parsec e s a -- ^ Parser to run-  -> String       -- ^ Name of source file-  -> s            -- ^ Input for parser-  -> Either (ParseError (Token s) e) a+-- > numbers = decimal `sepBy` char ','+--+-- '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@@ -189,423 +196,469 @@ -- will fail. -- -- The function is supposed to be useful for lightweight parsing, where--- error messages (and thus file name) 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.-+-- error messages (and thus file names) are not important and entire input+-- 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 expression @'parseTest' p input@ applies the parser @p@ on the -- input @input@ and prints the result to stdout. Useful for testing.--parseTest :: ( ShowErrorComponent e-             , Ord (Token s)-             , ShowToken (Token s)-             , Show a )-  => 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 (parseErrorPretty e)-    Right x -> print x---- | A version of 'parseTest' that also prints offending line in parse--- errors.------ @since 6.0.0--parseTest' :: ( ShowErrorComponent e-              , ShowToken (Token s)-              , LineToken (Token s)-              , Show a-              , Stream s )-  => Parsec e s a -- ^ Parser to run-  -> s            -- ^ Input for parser-  -> IO ()-parseTest' p input =-  case parse p "" input of-    Left  e -> putStr (parseErrorPretty' input e)+    Left e -> putStr (errorBundlePretty e)     Right x -> print x  -- | @'runParser' p file input@ runs parser @p@ on the input stream of -- tokens @input@, obtained from source @file@. The @file@ is only used in--- error messages and may be the empty string. Returns either a 'ParseError'--- ('Left') or a value of type @a@ ('Right').+-- error messages and may be the empty string. Returns either a+-- '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 (ParseError (Token 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    -- ^ Initial state-  -> (State s, Either (ParseError (Token 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 -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns a computation in the--- underlying monad @m@ that returns either a 'ParseError' ('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 (ParseError (Token s) e) a)-runParserT p name s = snd `liftM` runParserT' p (initialState name s)+-- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or+-- a value of type @a@ ('Right').+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 -- accepts and returns parser state. This is thus the most general way to -- run a parser. -- -- @since 4.2.0--runParserT' :: Monad m-  => ParsecT e s m a -- ^ Parser to run-  -> State s       -- ^ Initial state-  -> m (State s, Either (ParseError (Token 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-  case result of-    OK    x -> return (s', Right x)-    Error e -> return (s', Left  e)---- | Given name of source file and input construct initial state for parser.--initialState :: String -> s -> State s-initialState name s = State-  { stateInput           = s-  , statePos             = initialPos name :| []-  , stateTokensProcessed = 0-  , stateTabWidth        = defaultTabWidth }+  let toBundle es =+        ParseErrorBundle+          { bundleErrors =+              NE.sortWith errorOffset es,+            bundlePosState = statePosState s+          }+  return $ case result of+    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')))  ------------------------------------------------------------------------------- Derivatives of primitive combinators+-- Signaling parse errors --- | A synonym for 'label' in the form of an operator.+-- $parse-errors+--+-- The most general function to fail and end parsing is 'parseError'. These+-- are built on top of it. The section also includes functions starting with+-- the @register@ prefix which allow users to register “delayed”+-- 'ParseError's. -infix 0 <?>+-- | Stop parsing and report a trivial 'ParseError'.+--+-- @since 6.0.0+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)+{-# INLINE failure #-} -(<?>) :: MonadParsec e s m => m a -> String -> m a-(<?>) = flip label-{-# INLINE (<?>) #-}+-- | Stop parsing and report a fancy 'ParseError'. To report a single custom+-- parse error, see 'Text.Megaparsec.customFailure'.+--+-- @since 6.0.0+fancyFailure ::+  (MonadParsec e s m) =>+  -- | Fancy error components+  Set (ErrorFancy e) ->+  m a+fancyFailure xs = do+  o <- getOffset+  parseError (FancyError o xs)+{-# INLINE fancyFailure #-}  -- | The parser @'unexpected' item@ fails with an error message telling -- about unexpected item @item@ without consuming any input. ----- > unexpected item = failure (pure item) Set.empty--unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a-unexpected item = failure (pure item) E.empty+-- > unexpected item = failure (Just item) Set.empty+unexpected :: (MonadParsec e s m) => ErrorItem (Token s) -> m a+unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-}  -- | Report a custom parse error. For a more general version, see -- 'fancyFailure'. --+-- > 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 #-} --- | Return both the result of a parse and a chunk of input that was--- consumed during parsing. This relies on the change of the--- 'stateTokensProcessed' value to evaluate how many tokens were consumed.--- If you mess with it manually in the argument parser, prepare for--- troubles.------ @since 5.3.0--match :: MonadParsec e s m => m a -> m (Tokens s, a)-match p = do-  tp  <- getTokensProcessed-  s   <- getInput-  r   <- p-  tp' <- getTokensProcessed-  -- NOTE The 'fromJust' call here should never fail because if the stream-  -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing'-  -- as per its invariants), (tp' - tp) won't be greater than 0, and in that-  -- case 'Just' is guaranteed to be returned as per another invariant of-  -- 'takeN_'.-  return ((fst . fromJust) (takeN_ (tp' - tp) s), r)-{-# INLINEABLE match #-}- -- | Specify how to process 'ParseError's that happen inside of this--- wrapper. As a side effect of the current implementation changing--- 'errorPos' with this combinator will also change the final 'statePos' in--- the parser state (try to avoid that because 'statePos' will go out of--- sync with factual position in the input stream, which is probably OK if--- you finish parsing right after that, but be warned).+-- wrapper. This applies to both normal and delayed 'ParseError's. --+-- As a side-effect of the implementation the inner computation will start+-- 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 (Token s) e -> ParseError (Token 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 = []}   r <- observing m+  updateParserState $ \s ->+    s {stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar}   case r of-    Left err ->-      case f err of-        TrivialError pos us ps -> do-          updateParserState $ \st -> st { statePos = pos }-          failure us ps-        FancyError pos xs -> do-          updateParserState $ \st -> st { statePos = pos }-          fancyFailure xs+    Left err -> parseError (f err)     Right x -> return x {-# INLINEABLE region #-} --- | Consume the rest of the input and return it as a chunk. This parser--- never fails, but may return an empty chunk.------ > takeRest = takeWhileP Nothing (const True)+-- | 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 will+-- the parser succeed. This is the main way to report several parse errors+-- at once. ----- @since 6.0.0--takeRest :: MonadParsec e s m => m (Tokens s)-takeRest = takeWhileP Nothing (const True)-{-# INLINE takeRest #-}+-- @since 8.0.0+registerParseError :: (MonadParsec e s m) => ParseError s e -> m ()+registerParseError e = updateParserState $ \s ->+  s {stateParseErrors = e : stateParseErrors s}+{-# INLINE registerParseError #-} --- | Return 'True' when end of input has been reached.+-- | Like 'failure', but for delayed 'ParseError's. ----- @since 6.0.0+-- @since 8.0.0+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)+{-# INLINE registerFailure #-} -atEnd :: MonadParsec e s m => m Bool-atEnd = option False (True <$ hidden eof)-{-# INLINE atEnd #-}+-- | Like 'fancyFailure', but for delayed 'ParseError's.+--+-- @since 8.0.0+registerFancyFailure ::+  (MonadParsec e s m) =>+  -- | Fancy error components+  Set (ErrorFancy e) ->+  m ()+registerFancyFailure xs = do+  o <- getOffset+  registerParseError (FancyError o xs)+{-# INLINE registerFancyFailure #-}  ------------------------------------------------------------------------------- Parser state combinators---- | Return the current input.--getInput :: MonadParsec e s m => m s-getInput = stateInput <$> getParserState---- | @'setInput' input@ continues parsing with @input@. The 'getInput' and--- 'setInput' functions can for example be used to deal with include files.--setInput :: MonadParsec e s m => s -> m ()-setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w)+-- Derivatives of primitive combinators --- | Return the current source position.+-- | @'single' t@ only matches the single token @t@. ----- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--getPosition :: MonadParsec e s m => m SourcePos-getPosition = NE.head . statePos <$> getParserState---- | Get the position where the next token in the stream begins. If the--- stream is empty, return 'Nothing'.+-- > semicolon = single ';' ----- @since 5.3.0--getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos)-getNextTokenPosition = do-  State {..} <- getParserState-  let f = positionAt1 (Proxy :: Proxy s) (NE.head statePos)-  return (f . fst <$> take1_ stateInput)-{-# INLINEABLE getNextTokenPosition #-}---- | @'setPosition' pos@ sets the current source position to @pos@.+-- See also: 'token', 'anySingle', 'Text.Megaparsec.Byte.char',+-- 'Text.Megaparsec.Char.char'. ----- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--setPosition :: MonadParsec e s m => SourcePos -> m ()-setPosition pos = updateParserState $ \(State s (_:|z) tp w) ->-  State s (pos:|z) tp w+-- @since 7.0.0+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 :| []))+{-# INLINE single #-} --- | Push a position into stack of positions and continue parsing working--- with this position. Useful for working with include files and the like.+-- | The parser @'satisfy' f@ succeeds for any token for which the supplied+-- function @f@ returns 'True'. ----- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.+-- > digitChar = satisfy isDigit <?> "digit"+-- > oneOf cs  = satisfy (`elem` cs) ----- @since 5.0.0--pushPosition :: MonadParsec e s m => SourcePos -> m ()-pushPosition pos = updateParserState $ \(State s z tp w) ->-  State s (NE.cons pos z) tp w---- | Pop a position from the stack of positions unless it only contains one--- element (in that case the stack of positions remains the same). This is--- how to return to previous source file after 'pushPosition'.+-- __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: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.+-- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'. ----- @since 5.0.0--popPosition :: MonadParsec e s m => m ()-popPosition = updateParserState $ \(State s z tp w) ->-  case snd (NE.uncons z) of-    Nothing -> State s z  tp w-    Just z' -> State s z' tp w+-- @since 7.0.0+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+{-# INLINE satisfy #-} --- | Get the number of tokens processed so far.+-- | Parse and return a single token. It's a good idea to attach a 'label'+-- to this parser. ----- @since 6.0.0--getTokensProcessed :: MonadParsec e s m => m Int-getTokensProcessed = stateTokensProcessed <$> getParserState---- | Set the number of tokens processed so far.+-- > anySingle = satisfy (const True) ----- @since 6.0.0--setTokensProcessed :: MonadParsec e s m => Int -> m ()-setTokensProcessed tp = updateParserState $ \(State s pos _ w) ->-  State s pos tp w---- | Return the tab width. The default tab width is equal to--- 'defaultTabWidth'. You can set a different tab width with the help of--- 'setTabWidth'.--getTabWidth :: MonadParsec e s m => m Pos-getTabWidth = stateTabWidth <$> getParserState---- | Set tab width. If the argument of the function is not a positive--- number, 'defaultTabWidth' will be used.--setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState $ \(State s pos tp _) ->-  State s pos tp w---- | @'setParserState' st@ sets the parser state to @st@.+-- See also: 'satisfy', 'anySingleBut'.+--+-- @since 7.0.0+anySingle :: (MonadParsec e s m) => m (Token s)+anySingle = satisfy (const True)+{-# INLINE anySingle #-} -setParserState :: MonadParsec e s m => State s -> m ()-setParserState st = updateParserState (const st)+-- | Match any token but the given one. It's a good idea to attach a 'label'+-- to this parser.+--+-- > anySingleBut t = satisfy (/= t)+--+-- See also: 'single', 'anySingle', 'satisfy'.+--+-- @since 7.0.0+anySingleBut ::+  (MonadParsec e s m) =>+  -- | Token we should not match+  Token s ->+  m (Token s)+anySingleBut t = satisfy (/= t)+{-# INLINE anySingleBut #-} -------------------------------------------------------------------------------- Debugging+-- | @'oneOf' ts@ succeeds if the current token is in the supplied+-- collection of tokens @ts@. Returns the parsed token. Note that this+-- parser cannot automatically generate the “expected” component of error+-- message, so usually you should label it manually with 'label' or ('<?>').+--+-- > oneOf cs = satisfy (`elem` cs)+--+-- See also: 'satisfy'.+--+-- > digit = oneOf ['0'..'9'] <?> "digit"+--+-- __Performance note__: prefer 'satisfy' when you can because it's faster+-- when you have only a couple of tokens to compare to:+--+-- > quoteFast = satisfy (\x -> x == '\'' || x == '\"')+-- > quoteSlow = oneOf "'\""+--+-- @since 7.0.0+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 #-} --- | @'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.+-- | 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+-- 'label' or ('<?>'). ----- 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.+-- > noneOf cs = satisfy (`notElem` cs) ----- The output itself is pretty self-explanatory, although the following--- abbreviations should be clarified (they are derived from the low-level--- source code):+-- See also: 'satisfy'. -----     * @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.+-- __Performance note__: prefer 'satisfy' and 'anySingleBut' when you can+-- because it's faster. ----- 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 'MonadParsec' in general.+-- @since 7.0.0+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@. ----- @since 5.1.0+-- > divOrMod = chunk "div" <|> chunk "mod"+--+-- See also: 'tokens', 'Text.Megaparsec.Char.string',+-- 'Text.Megaparsec.Byte.string'.+--+-- @since 7.0.0+chunk ::+  (MonadParsec e s m) =>+  -- | Chunk to match+  Tokens s ->+  m (Tokens s)+chunk = tokens (==)+{-# INLINE chunk #-} -dbg :: forall e s m a.-  ( Stream s-  , ShowToken (Token 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'+-- | A synonym for 'label' in the form of an operator.+infix 0 <?> --- | A single piece of info to be rendered with 'dbgLog'.+(<?>) :: (MonadParsec e s m) => m a -> String -> m a+(<?>) = flip label+{-# INLINE (<?>) #-} -data DbgItem s e a-  = DbgIn   [Token s]-  | DbgCOK  [Token s] a-  | DbgCERR [Token s] (ParseError (Token s) e)-  | DbgEOK  [Token s] a-  | DbgEERR [Token s] (ParseError (Token s) e)+-- | Return both the result of a parse and a chunk of input that was+-- consumed during parsing. This relies on the change of the 'stateOffset'+-- value to evaluate how many tokens were consumed. If you mess with it+-- manually in the argument parser, prepare for troubles.+--+-- @since 5.3.0+match :: (MonadParsec e s m) => m a -> m (Tokens s, a)+match p = do+  o <- getOffset+  s <- getInput+  r <- p+  o' <- getOffset+  -- NOTE The 'fromJust' call here should never fail because if the stream+  -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing'+  -- as per its invariants), (tp' - tp) won't be greater than 0, and in that+  -- case 'Just' is guaranteed to be returned as per another invariant of+  -- 'takeN_'.+  return ((fst . fromJust) (takeN_ (o' - o) s), r)+{-# INLINEABLE match #-} --- | Render a single piece of debugging info.+-- | Consume the rest of the input and return it as a chunk. This parser+-- never fails, but may return the empty chunk.+--+-- > takeRest = takeWhileP Nothing (const True)+--+-- @since 6.0.0+takeRest :: (MonadParsec e s m) => m (Tokens s)+takeRest = takeWhileP Nothing (const True)+{-# INLINE takeRest #-} -dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s))-  => String            -- ^ Debugging label-  -> DbgItem s e a     -- ^ Information to render-  -> String            -- ^ Rendered result-dbgLog lbl item = prefix msg-  where-    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines-    msg = case item of-      DbgIn   ts   ->-        "IN: " ++ showStream ts-      DbgCOK  ts a ->-        "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgCERR ts e ->-        "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e-      DbgEOK  ts a ->-        "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgEERR ts e ->-        "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e+-- | Return 'True' when end of input has been reached.+--+-- > atEnd = option False (True <$ hidden eof)+--+-- @since 6.0.0+atEnd :: (MonadParsec e s m) => m Bool+atEnd = option False (True <$ hidden eof)+{-# INLINE atEnd #-} --- | Pretty-print a list of tokens.+----------------------------------------------------------------------------+-- Parser state combinators -showStream :: ShowToken t => [t] -> String-showStream ts =-  case NE.nonEmpty ts of-    Nothing -> "<EMPTY>"-    Just ne ->-      let (h, r) = splitAt 40 (showTokens ne)-      in if null r then h else h ++ " <…>"+-- | Return the current input.+getInput :: (MonadParsec e s m) => m s+getInput = stateInput <$> getParserState+{-# INLINE getInput #-} --- | Calculate number of consumed tokens given 'State' of parser before and--- after parsing.+-- | @'setInput' input@ continues parsing with @input@.+setInput :: (MonadParsec e s m) => s -> m ()+setInput s = updateParserState (\(State _ o pst de) -> State s o pst de)+{-# INLINE setInput #-} -streamDelta-  :: State s           -- ^ State of parser before consumption-  -> State s           -- ^ State of parser after consumption-  -> Int               -- ^ Number of consumed tokens-streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0+-- | Return the current source position. This function /is not cheap/, do+-- not call it e.g. on matching of every token, that's a bad idea. Still you+-- can use it to get 'SourcePos' to attach to things that you parse.+--+-- The function works under the assumption that we move in the input stream+-- only forwards and never backwards, which is always true unless the user+-- abuses the library.+--+-- @since 7.0.0+getSourcePos :: (TraversableStream s, MonadParsec e s m) => m SourcePos+getSourcePos = do+  st <- getParserState+  let pst = reachOffsetNoLine (stateOffset st) (statePosState st)+  setParserState st {statePosState = pst}+  return (pstateSourcePos pst)+{-# INLINE getSourcePos #-} --- | Extract a given number of tokens from the stream.+-- | Get the number of tokens processed so far.+--+-- See also: 'setOffset'.+--+-- @since 7.0.0+getOffset :: (MonadParsec e s m) => m Int+getOffset = stateOffset <$> getParserState+{-# INLINE getOffset #-} -streamTake :: forall s. Stream s => Int -> s -> [Token s]-streamTake n s =-  case fst <$> takeN_ n s of-    Nothing -> []-    Just chunk -> chunkToTokens (Proxy :: Proxy s) chunk+-- | Set the number of tokens processed so far.+--+-- See also: 'getOffset'.+--+-- @since 7.0.0+setOffset :: (MonadParsec e s m) => Int -> m ()+setOffset o = updateParserState $ \(State s _ pst de) ->+  State s o pst de+{-# INLINE setOffset #-}++-- | @'setParserState' st@ sets the parser state to @st@.+--+-- See also: 'getParserState', 'updateParserState'.+setParserState :: (MonadParsec e s m) => State s e -> m ()+setParserState st = updateParserState (const st)+{-# INLINE setParserState #-}
Text/Megaparsec/Byte.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module      :  Text.Megaparsec.Byte--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -10,179 +15,190 @@ -- 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-  , octDigitChar-  , hexDigitChar-  , asciiChar-    -- * More general parsers-  , C.char-  , char'-  , C.anyChar-  , C.notChar-  , C.oneOf-  , C.noneOf-  , C.satisfy+    controlChar,+    spaceChar,+    upperChar,+    lowerChar,+    letterChar,+    alphaNumChar,+    printChar,+    digitChar,+    binDigitChar,+    octDigitChar,+    hexDigitChar,+    asciiChar,++    -- * Single byte+    char,+    char',+     -- * Sequence of bytes-  , C.string-  , C.string' )+    string,+    string',+  ) where  import Control.Applicative-import Data.Char+import Data.Char hiding (isSpace, toLower, toUpper) import Data.Functor (void)-import Data.Maybe (fromMaybe) import Data.Proxy import Data.Word (Word8) import Text.Megaparsec-import qualified Text.Megaparsec.Char as C+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- Simple parsers  -- | Parse a newline byte.- newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-newline = C.char 10+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 = C.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 = C.char 9+tab = char 9 {-# INLINE tab #-}  -- | 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 = C.satisfy (isControl . toChar) <?> "control character"+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 = C.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 = C.satisfy (isUpper . toChar) <?> "uppercase letter"+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 = C.satisfy (isLower . toChar) <?> "lowercase letter"+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 = C.satisfy (isLetter . toChar) <?> "letter"+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 = C.satisfy (isAlphaNum . toChar) <?> "alphanumeric character"+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 = C.satisfy (isPrint . toChar) <?> "printable character"+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 = C.satisfy isDigit' <?> "digit"+digitChar = satisfy isDigit' <?> "digit"   where     isDigit' x = x >= 48 && x <= 57 {-# INLINE digitChar #-} --- | Parse an octal digit, i.e. between “0” and “7”.+-- | 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+    isBinDigit x = x == 48 || x == 49+{-# INLINE binDigitChar #-} +-- | Parse an octal digit, i.e. between “0” and “7”. octDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-octDigitChar = C.satisfy isOctDigit' <?> "octal digit"+octDigitChar = satisfy isOctDigit' <?> "octal digit"   where     isOctDigit' x = x >= 48 && x <= 55 {-# 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 ~ Word8) => m (Token s)-hexDigitChar = C.satisfy (isHexDigit . toChar) <?> "hexadecimal digit"+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 = C.satisfy (< 128) <?> "ASCII character"+asciiChar = satisfy (< 128) <?> "ASCII character" {-# INLINE asciiChar #-}  ------------------------------------------------------------------------------- More general parsers+-- Single byte +-- | 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 #-}+ -- | The same as 'char' but case-insensitive. This parser returns the -- actually parsed character preserving its case. --@@ -192,44 +208,57 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e'- char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s)-char' c = choice-  [ C.char c-  , C.char (fromMaybe c (swapCase c)) ]-  where-    swapCase x-      | isUpper g = fromChar (toLower g)-      | isLower g = fromChar (toUpper g)-      | otherwise = Nothing-      where-        g = toChar x+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 char to byte.+-- | Convert a byte to its upper-case version.+toUpper :: Word8 -> Word8+toUpper x+  | x >= 97 && x <= 122 = x - 32+  | x == 247 = x -- division sign+  | x == 255 = x -- latin small letter y with diaeresis+  | x >= 224 = x - 32+  | otherwise = x+{-# INLINE toUpper #-} -fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in-  if p > 0xff-    then Nothing-    else Just (fromIntegral p)-{-# INLINE fromChar #-}+-- | Convert a byte to its lower-case version.+toLower :: Word8 -> Word8+toLower x+  | x >= 65 && x <= 90 = x + 32+  | x == 215 = x -- multiplication sign+  | x >= 192 && x <= 222 = x + 32+  | otherwise = x+{-# INLINE toLower #-}
+ 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,6 +1,11 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module      :  Text.Megaparsec.Byte.Lexer--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -13,108 +18,139 @@ -- 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-    C.space-  , C.lexeme-  , C.symbol-  , C.symbol'-  , skipLineComment-  , skipBlockComment-  , skipBlockCommentNested+    space,+    lexeme,+    symbol,+    symbol',+    skipLineComment,+    skipBlockComment,+    skipBlockCommentNested,+     -- * Numbers-  , decimal-  , 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.Byte-import qualified Data.Scientific            as Sci-import qualified Text.Megaparsec.Char.Lexer as C+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 =-  string prefix *> void (takeWhileP (Just "character") (/= 10))+  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 start end = p >> void (manyTill anyChar n)+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 = string start-    n = string end+    p = B.string start+    n = B.string end {-# INLINEABLE skipBlockComment #-}  -- | @'skipBlockCommentNested' start end@ skips possibly nested block -- 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 anyChar-    p = string start-    n = string end+    e = skipBlockCommentNested start end <|> void anySingle+    p = B.string start+    n = B.string end {-# INLINEABLE skipBlockCommentNested #-}  ---------------------------------------------------------------------------- -- 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 'signed' combinator.--decimal-  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)-  => m a+-- If you need to parse signed integers, see the 'signed' combinator.+--+-- __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, Integral 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 octal representation. Representation of octal+-- | 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"+  where+    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 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@@ -122,21 +158,24 @@ -- -- For example you can make it conform to the Haskell report like this: ----- > octal = char '0' >> char' 'o' >> L.octal--octal-  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)-  => m a-octal = mkNum-  <$> takeWhile1P Nothing isOctDigit-  <?> "octal integer"+-- > octal = char 48 >> char' 111 >> L.octal+--+-- __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@@ -144,24 +183,27 @@ -- -- For example you can make it conform to the Haskell report like this: ----- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal--hexadecimal-  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)-  => m a-hexadecimal = mkNum-  <$> takeWhile1P Nothing isHexDigit-  <?> "hexadecimal integer"+-- > hexadecimal = char 48 >> char' 120 >> L.hexadecimal+--+-- __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@@ -174,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 #-} @@ -193,36 +235,41 @@ -- 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 (char 46)-  let mkNum    = foldl' step (SP c' 0) . chunkToTokens pxy-      step (SP a e') w = SP-        (a * 10 + fromIntegral (w - 48))-        (e' - 1)+  void (B.char 46)+  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 (char' 101)+  void (B.char' 101)   (+ e') <$> signed (return ()) decimal_ {-# INLINE exponent_ #-} @@ -237,21 +284,23 @@ -- > 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 spc p = ($) <$> option id (C.lexeme spc sign) <*> p+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 <$ char 43) <|> (negate <$ char 45)+    sign = (id <$ B.char 43) <|> (negate <$ B.char 45) {-# INLINEABLE signed #-}  ---------------------------------------------------------------------------- -- 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,6 +1,13 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module      :  Text.Megaparsec.Char--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -10,96 +17,80 @@ -- Portability :  non-portable -- -- Commonly used character parsers.--{-# LANGUAGE CPP                 #-}-{-# 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-  , octDigitChar-  , hexDigitChar-  , markChar-  , numberChar-  , punctuationChar-  , symbolChar-  , separatorChar-  , asciiChar-  , latin1Char-  , charCategory-  , categoryName-    -- * More general parsers-  , char-  , char'-  , anyChar-  , notChar-  , oneOf-  , noneOf-  , satisfy+    controlChar,+    spaceChar,+    upperChar,+    lowerChar,+    letterChar,+    alphaNumChar,+    printChar,+    digitChar,+    binDigitChar,+    octDigitChar,+    hexDigitChar,+    markChar,+    numberChar,+    punctuationChar,+    symbolChar,+    separatorChar,+    asciiChar,+    latin1Char,+    charCategory,+    categoryName,++    -- * Single character+    char,+    char',+     -- * Sequence of characters-  , string-  , string' )+    string,+    string',+  ) where  import Control.Applicative import Data.Char-import Data.Function (on) import Data.Functor (void)-import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Text.Megaparsec-import qualified Data.CaseInsensitive as CI-import qualified Data.Set             as E--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (), elem, notElem)-import Prelude hiding (elem, notElem)-#endif+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- 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 #-}@@ -107,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 #-}@@ -142,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 #-}@@ -165,144 +163,133 @@ -- 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 #-} --- | Parse an octal digit, i.e. between “0” and “7”.+-- | 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+    isBinDigit x = x == '0' || x == '1'+{-# 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"  ------------------------------------------------------------------------------- More general parsers+-- Single character --- | @'char' c@ parses a single character @c@.+-- | A type-constrained version of 'single'. -- -- > semicolon = char ';'--char :: MonadParsec e s m => Token s -> m (Token s)-char c = token testChar (Just c)-  where-    f x = Tokens (x:|[])-    testChar x =-      if x == c-        then Right x-        else Left (pure (f x), E.singleton (f c))+char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s)+char = single {-# INLINE char #-}  -- | The same as 'char' but case-insensitive. This parser returns the@@ -314,110 +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 c, char (swapCase c)]-  where-    swapCase x-      | isUpper x = toLower x-      | isLower x = toUpper x-      | otherwise = x+char' c =+  choice+    [ char (toLower c),+      char (toUpper c),+      char (toTitle c)+    ] {-# INLINE char' #-} --- | This parser succeeds for any character. Returns the parsed character.--anyChar :: MonadParsec e s m => m (Token s)-anyChar = satisfy (const True) <?> "character"-{-# INLINE anyChar #-}---- | Match any character but the given one. It's a good idea to attach a--- 'label' to this parser manually.------ @since 6.0.0--notChar :: MonadParsec e s m => Token s -> m (Token s)-notChar c = satisfy (/= c)-{-# INLINE notChar #-}---- | @'oneOf' cs@ succeeds if the current character is in the supplied--- collection of characters @cs@. 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 'label' or--- ('<?>').------ See also: 'satisfy'.------ > digit = oneOf ['0'..'9'] <?> "digit"------ __Performance note__: prefer 'satisfy' when you can because it's faster--- when you have only a couple of tokens to compare to:------ > quoteFast = satisfy (\x -> x == '\'' || x == '\"')--- > quoteSlow = oneOf "'\""--oneOf :: (Foldable f, MonadParsec e s m)-  => f (Token s)-  -> m (Token s)-oneOf cs = satisfy (`elem` cs)-{-# INLINE oneOf #-}---- | As the dual of 'oneOf', @'noneOf' cs@ succeeds if the current character--- /not/ in the supplied list of characters @cs@. 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 'label' or ('<?>').------ See also: 'satisfy'.------ __Performance note__: prefer 'satisfy' and 'notChar' when you can because--- it's faster.--noneOf :: (Foldable f, MonadParsec e s m)-  => f (Token s)-  -> m (Token s)-noneOf cs = satisfy (`notElem` cs)-{-# INLINE noneOf #-}---- | The parser @'satisfy' f@ succeeds for any character for which the--- supplied function @f@ returns 'True'. Returns the character that is--- actually parsed.------ > digitChar = satisfy isDigit <?> "digit"--- > oneOf cs  = satisfy (`elem` cs)--satisfy :: MonadParsec e s m-  => (Token s -> Bool) -- ^ Predicate to apply-  -> m (Token s)-satisfy f = token testChar Nothing-  where-    testChar x =-      if f x-        then Right x-        else Left (pure (Tokens (x:|[])), E.empty)-{-# INLINE satisfy #-}- ------------------------------------------------------------------------------- Sequence of characters---- | @'string' s@ parses a sequence of characters given by @s@. Returns the--- parsed string (i.e. @s@).------ > divOrMod = string "div" <|> string "mod"--string :: MonadParsec e s m-  => Tokens s-  -> m (Tokens s)-string = tokens (==)-{-# INLINE string #-}---- | The same as 'string', but case-insensitive. On success returns string--- cased as actually parsed input.------ >>> parseTest (string' "foobar") "foObAr"--- "foObAr"+-- Helpers -string' :: (MonadParsec e s m, CI.FoldCase (Tokens s))-  => Tokens s-  -> m (Tokens s)-string' = tokens ((==) `on` CI.mk)-{-# INLINE string' #-}+-- | Is it a horizontal space character?+isHSpace :: Char -> Bool+isHSpace x = isSpace x && x /= '\n' && x /= '\r'
Text/Megaparsec/Char/Lexer.hs view
@@ -1,6 +1,13 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module      :  Text.Megaparsec.Char.Lexer--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -11,8 +18,7 @@ -- -- High-level parsers to help you write your lexer. The module doesn't -- impose how you should write your parser, but certain approaches may be--- more elegant than others. Especially important theme is parsing of white--- space, comments, and indentation.+-- more elegant than others. -- -- Parsing of white space is an important part of any parser. We propose a -- convention where __every lexeme parser assumes no spaces before the__@@ -27,159 +33,79 @@ -- > import qualified Text.Megaparsec.Char.Lexer as L -- -- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer".--{-# LANGUAGE CPP                 #-}-{-# 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-  , 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 qualified Data.CaseInsensitive as CI-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 --- | @'space' sc lineComment blockComment@ produces 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.------ @lineComment@ is used to parse line comments. You can use--- 'skipLineComment' if you don't need anything special.------ @blockComment@ is used to parse block (multi-line) comments. You can use--- 'skipBlockComment' or 'skipBlockCommentNested' if you don't need anything--- special.------ If you don't want to allow a kind of comment, simply pass 'empty' which--- 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]-{-# INLINEABLE space #-}---- | This is a wrapper for lexemes. 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 spc p = p <* spc-{-# INLINEABLE lexeme #-}---- | This is a helper to parse symbols, i.e. verbatim strings. You pass the--- first argument (parser that consumes white space, probably defined via--- 'space') and then you can use the resulting function to parse strings:------ > symbol    = L.symbol spaceConsumer--- >--- > parens    = between (symbol "(") (symbol ")")--- > braces    = between (symbol "{") (symbol "}")--- > angles    = between (symbol "<") (symbol ">")--- > brackets  = between (symbol "[") (symbol "]")--- > semicolon = symbol ";"--- > 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 spc = lexeme spc . C.string-{-# INLINEABLE symbol #-}---- | Case-insensitive version of 'symbol'. This may be helpful if you're--- working with case-insensitive languages.--symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s))-  => m ()              -- ^ How to consume white space after lexeme-  -> Tokens s          -- ^ Symbol to parse (case-insensitive)-  -> m (Tokens s)-symbol' spc = lexeme spc . C.string'-{-# INLINEABLE symbol' #-}---- | 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 start end = p >> void (manyTill C.anyChar n)+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     n = C.string end@@ -189,14 +115,16 @@ -- 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 C.anyChar+    e = skipBlockCommentNested start end <|> void anySingle     p = C.string start     n = C.string end {-# INLINEABLE skipBlockCommentNested #-}@@ -211,10 +139,9 @@ -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0--indentLevel :: MonadParsec e s m => m Pos-indentLevel = sourceColumn <$> getPosition-{-# INLINEABLE indentLevel #-}+indentLevel :: (TraversableStream s, MonadParsec e s m) => m Pos+indentLevel = sourceColumn <$> getSourcePos+{-# INLINE indentLevel #-}  -- | Fail reporting incorrect indentation error. The error has attached -- information:@@ -224,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@@ -244,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@@ -263,52 +198,54 @@ -- 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 #-} --- | The data type represents available behaviors for parsing of indented--- tokens. This is used in 'indentBlock', which see.+-- | Behaviors for parsing of indented tokens. This is used in+-- '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 -> sc *> return x+    IndentNone x -> x <$ sc     IndentMany indent f p -> do       mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)       done <- isJust <$> optional eof@@ -319,40 +256,48 @@     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/ -- consume newlines in order to work properly. The second argument is a--- callback that receives a custom space-consuming parser as argument. This--- parser should be used after separate components of line fold that can be--- put on different lines.+-- callback that receives a custom space-consuming parser as an argument.+-- This parser should be used after separate components of line fold that+-- can be put on different lines. -- -- An example should clarify the usage pattern: --@@ -364,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 #-}@@ -392,45 +339,68 @@ -- -- __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,   -- and we do know that r will be non-empty if count' succeeds.-  r <- lookAhead (count' 1 8 C.anyChar)+  r <- lookAhead (count' 1 10 anySingle)   case listToMaybe (Char.readLitChar r) of-    Just (c, r') -> c <$ skipCount (length r - length r') C.anyChar-    Nothing      -> unexpected (Tokens (head r:|[]))+    Just (c, r') -> c <$ skipCount (length r - length r') anySingle+    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 'signed' combinator.+-- 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.--decimal-  :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a)-  => m a+-- __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, Integral 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 octal representation. Representation of octal+-- | 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"+  where+    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 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@@ -440,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, Integral 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@@ -464,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, Integral 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 #-} @@ -490,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 #-} @@ -509,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:@@ -556,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,6 +1,13 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module      :  Text.Megaparsec.Class--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -13,86 +20,54 @@ -- the full set of primitive parsers. -- -- @since 6.5.0--{-# LANGUAGE CPP                    #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE UndecidableInstances   #-}- module Text.Megaparsec.Class-  ( MonadParsec (..) )+  ( MonadParsec (..),+  ) where -import Control.Applicative 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 -#if !MIN_VERSION_mtl(2,2,2)-import Control.Monad.Trans.Identity-#endif--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif- -- | Type class describing monads that implement the full set of primitive -- parsers. ----- __Note carefully__ 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, Alternative m, MonadPlus m)-    => MonadParsec e s m | m -> e s where--  -- | The most general way to stop parsing and report a trivial-  -- 'ParseError'.-  ---  -- @since 6.0.0--  failure-    :: Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any)-    -> Set (ErrorItem (Token s)) -- ^ Expected items-    -> m a--  -- | The most general way to stop parsing and report a fancy 'ParseError'.-  -- To report a single custom parse error, see 'customFailure'.+-- __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 the parser state+  -- manually.   ---  -- @since 6.0.0--  fancyFailure-    :: Set (ErrorFancy e) -- ^ Fancy error components-    -> m a+  -- @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).   --@@ -125,12 +100,11 @@   -- unexpected "le"   -- expecting "let" or "lexical"   ---  -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks-  -- automatically (see 'tokens'), so it does not need 'try'. 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+  -- __Note__ that as of Megaparsec 4.4.0, 'Text.Megaparsec.Char.string'+  -- backtracks automatically (see 'tokens'), so it does not need 'try'.+  -- 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)@@ -138,81 +112,76 @@   -- (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 (Token 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 (Token s) e) a)--  -- | This parser only succeeds at the end of the input.+  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 mrep@ accepts a token @t@ with result @x@-  -- when the function @test t@ returns @'Right' x@. @mrep@ may provide-  -- representation of the token to report in error messages when input-  -- stream in empty.+  -- | 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.Char.satisfy' parser is implemented as:+  -- For example, the 'Text.Megaparsec.satisfy' parser is implemented as:   ---  -- > satisfy f = token testChar Nothing+  -- > satisfy f = token testToken Set.empty   -- >   where-  -- >     testChar x =-  -- >       if f x-  -- >         then Right x-  -- >         else Left (pure (Tokens (x:|[])), Set.empty)--  token-    :: (Token s -> Either ( Maybe (ErrorItem (Token s))-                          , Set (ErrorItem (Token s)) ) a)-       -- ^ Matching function for the token to parse, it allows to construct-       -- arbitrary error message on failure as well; things in the tuple-       -- are: unexpected item (if any) and expected items-    -> Maybe (Token s) -- ^ Token to report when input stream is empty-    -> m a+  -- >     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 ::+    -- | 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@ parses a chunk of input and returns it.-  -- Supplied predicate @test@ is used to check equality of given and parsed-  -- chunks after a candidate chunk of correct length is fetched from the-  -- stream.+  -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and+  -- returns it. The supplied predicate @test@ is used to check equality of+  -- given and parsed chunks after a candidate chunk of correct length is+  -- fetched from the stream.   ---  -- This can be used for example to write 'Text.Megaparsec.Char.string':+  -- This can be used for example to write 'Text.Megaparsec.chunk':   ---  -- > string = tokens (==)+  -- > chunk = tokens (==)   --   -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking   -- primitive, which means that if it fails, it never consumes any input.@@ -229,260 +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-  -- combinator is much faster than parsers built with 'many' and-  -- 'Text.Megaparsec.Char.satisfy'.-  ---  -- The following equations should clarify the behavior:+  -- 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'.   --   -- > takeWhileP (Just "foo") f = many (satisfy f <?> "foo")   -- > takeWhileP Nothing      f = many (satisfy f)   ---  -- The combinator never fails, although it may parse an empty chunk.+  -- 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)+  getParserState :: m (State s e)    -- | @'updateParserState' f@ applies the function @f@ to the parser state.+  updateParserState :: (State s e -> State s e) -> m () -  updateParserState :: (State s -> State s) -> 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-  failure us ps              = lift (failure us ps)-  fancyFailure xs            = lift (fancyFailure xs)-  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-  failure us ps              = lift (failure us ps)-  fancyFailure xs            = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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-  failure us ps               = lift (failure us ps)-  fancyFailure xs             = lift (fancyFailure xs)-  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
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Common token combinators. This module is not public, the functions from+-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char".+--+-- @since 7.0.0+module Text.Megaparsec.Common+  ( string,+    string',+  )+where++import qualified Data.CaseInsensitive as CI+import Data.Function (on)+import Text.Megaparsec++-- | A synonym for 'chunk'.+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 the parsed input.+--+-- >>> parseTest (string' "foobar") "foObAr"+-- "foObAr"+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
@@ -0,0 +1,333 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Unsafe #-}++-- |+-- Module      :  Text.Megaparsec.Debug+-- Copyright   :  © 2015–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Debugging helpers.+--+-- @since 7.0.0+module Text.Megaparsec.Debug+  ( 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++-- | Type class describing parser monads that can trace during evaluation.+--+-- @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@:+--+-- >>> 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@:+--+-- >>> 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@:+--+-- >>> 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 (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++-- | @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 (Hints (Token s))+  | DbgCERR [Token s] (ParseError s e)+  | 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.+  (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 ->+        "IN: " ++ showStream pxy ts+      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 (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 :: (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 ++ " <…>"++-- | Calculate number of consumed tokens given 'State' of parser before and+-- after parsing.+streamDelta ::+  -- | State of parser before consumption+  State s e ->+  -- | State of parser after consumption+  State s e ->+  -- | Number of consumed tokens+  Int+streamDelta s0 s1 = stateOffset s1 - stateOffset s0++-- | Extract a given number of tokens from the stream.+streamTake :: forall s. (Stream s) => Int -> s -> [Token s]+streamTake n s =+  case fst <$> takeN_ n s of+    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,176 +1,222 @@+{-# 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–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com> -- Stability   :  experimental -- Portability :  portable ----- Parse errors. Current version of Megaparsec supports well-typed errors+-- 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 CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Text.Megaparsec.Error   ( -- * Parse error type-    ErrorItem (..)-  , ErrorFancy (..)-  , ParseError (..)-  , errorPos+    ErrorItem (..),+    ErrorFancy (..),+    ParseError (..),+    mapParseError,+    errorOffset,+    setErrorOffset,+    ParseErrorBundle (..),+    attachSourcePos,+     -- * Pretty-printing-  , ShowToken (..)-  , LineToken (..)-  , ShowErrorComponent (..)-  , parseErrorPretty-  , parseErrorPretty'-  , parseErrorPretty_-  , sourcePosStackPretty-  , parseErrorTextPretty )+    ShowErrorComponent (..),+    errorBundlePretty,+    errorBundlePrettyForGhcPreProcessors,+    errorBundlePrettyWith,+    parseErrorPretty,+    parseErrorTextPretty,+    showErrorItem,+  ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception-import Data.Char (chr)+import Control.Monad.State.Strict import Data.Data (Data) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, isNothing)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isNothing) import Data.Proxy-import Data.Semigroup import Data.Set (Set)+import qualified Data.Set as E import Data.Typeable (Typeable) import Data.Void-import Data.Word (Word8) import GHC.Generics-import Prelude hiding (concat) 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--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif+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, can be conveniently disabled by indexing-    -- 'ErrorFancy' by 'Void'-  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 --- | @'ParseError' t e@ represents a parse error parametrized over the token--- type @t@ and the custom data @e@.------ Note that the stack of source positions contains current position as its--- head, and the rest of positions allows to track full sequence of include--- files with topmost source file at the end of the list.+-- | @'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 6.0.0+-- @since 7.0.0+data ParseError s e+  = -- | 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/.+    TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))+  | -- | Fancy, custom errors.+    --+    -- Type of the first argument was changed in the version /7.0.0/.+    FancyError Int (Set (ErrorFancy e))+  deriving (Generic) -data ParseError t e-  = TrivialError (NonEmpty SourcePos) (Maybe (ErrorItem t)) (Set (ErrorItem t))-    -- ^ Trivial errors, generated by Megaparsec's machinery. The data-    -- constructor includes the stack of source positions, unexpected token-    -- (if any), and expected tokens.-  | FancyError (NonEmpty SourcePos) (Set (ErrorFancy e))-    -- ^ Fancy, custom errors.-  deriving (Show, Read, Eq, Data, Typeable, Generic)+deriving instance+  ( Show (Token s),+    Show e+  ) =>+  Show (ParseError s e) -instance (NFData t, NFData e) => NFData (ParseError t e)+deriving instance+  ( Eq (Token s),+    Eq e+  ) =>+  Eq (ParseError s e) -instance (Ord t, Ord e) => Semigroup (ParseError t e) where+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 (Stream s, Ord e) => Semigroup (ParseError s e) where   (<>) = mergeError   {-# INLINE (<>) #-} -instance (Ord t, Ord e) => Monoid (ParseError t e) where-  mempty  = TrivialError (initialPos "" :| []) Nothing E.empty+instance (Stream s, Ord e) => Monoid (ParseError s e) where+  mempty = TrivialError 0 Nothing E.empty   mappend = (<>)   {-# INLINE mappend #-} -instance ( Show t-         , Ord t-         , ShowToken t-         , Typeable t-         , Show e-         , ShowErrorComponent e-         , Typeable e )-  => Exception (ParseError t e) where-#if MIN_VERSION_base(4,8,0)+instance+  ( Show (Token s),+    Show e,+    ShowErrorComponent e,+    VisualStream s,+    Typeable s,+    Typeable e+  ) =>+  Exception (ParseError s e)+  where   displayException = parseErrorPretty-#endif --- | Get position of given 'ParseError'.+-- | Modify the custom data component in a parse error. This could be done+-- via 'fmap' if not for the 'Ord' constraint. ----- @since 6.0.0+-- @since 7.0.0+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) -errorPos :: ParseError t e -> NonEmpty SourcePos-errorPos (TrivialError p _ _) = p-errorPos (FancyError   p _)   = p+-- | Get the offset of a 'ParseError'.+--+-- @since 7.0.0+errorOffset :: ParseError s e -> Int+errorOffset (TrivialError o _ _) = o+errorOffset (FancyError o _) = o +-- | 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+ -- | Merge two error data structures into one joining their collections of -- message items and preferring the longest match. In other words, earlier -- 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 :: (Ord t, Ord e)-  => ParseError t e-  -> ParseError t e-  -> ParseError t e+mergeError ::+  (Stream s, Ord e) =>+  ParseError s e ->+  ParseError s e ->+  ParseError s e mergeError e1 e2 =-  case errorPos e1 `compare` errorPos e2 of+  case errorOffset e1 `compare` errorOffset e2 of     LT -> e2     EQ ->       case (e1, e2) of@@ -190,304 +236,341 @@     -- 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 #-} -------------------------------------------------------------------------------- Pretty-printing---- | Type class 'ShowToken' includes methods that allow to pretty-print--- single token as well as stream of tokens. This is used for rendering of--- error messages.+-- | A non-empty collection of 'ParseError's equipped with 'PosState' that+-- allows us to pretty-print the errors efficiently and correctly. ----- @since 5.0.0+-- @since 7.0.0+data ParseErrorBundle s e = ParseErrorBundle+  { -- | 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) -class ShowToken a where+deriving instance+  ( Show s,+    Show (Token s),+    Show e+  ) =>+  Show (ParseErrorBundle s e) -  -- | Pretty-print non-empty stream of tokens. This function is also used-  -- to print single tokens (represented as singleton lists).+deriving instance+  ( Eq s,+    Eq (Token s),+    Eq e+  ) =>+  Eq (ParseErrorBundle s e) -  showTokens :: NonEmpty a -> String+deriving instance+  ( Data s,+    Data (Token s),+    Ord (Token s),+    Data e,+    Ord e+  ) =>+  Data (ParseErrorBundle s e) -instance ShowToken Char where-  showTokens = stringPretty+instance+  ( NFData s,+    NFData (Token s),+    NFData e+  ) =>+  NFData (ParseErrorBundle s e) -instance ShowToken Word8 where-  showTokens = stringPretty . fmap (chr . fromIntegral)+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 --- | Type class for tokens that support operations necessary for selecting--- and displaying relevant line of input.+-- | Attach 'SourcePos'es to items in a 'Traversable' container given that+-- there is a projection allowing us to get an offset per item. ----- @since 6.0.0--class LineToken a where--  -- | Convert a token to a 'Char'. This is used to print relevant line from-  -- input stream by turning a list of tokens into a 'String'.--  tokenAsChar :: a -> Char--  -- | Check if given token is a newline or contains newline.--  tokenIsNewline :: a -> Bool--instance LineToken Char where-  tokenAsChar = id-  tokenIsNewline x = x == '\n'+-- Items must be in ascending order with respect to their offsets.+--+-- @since 7.0.0+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+      pst <- get+      let pst' = reachOffsetNoLine (projectOffset a) pst+      put pst'+      return (a, pstateSourcePos pst')+{-# INLINEABLE attachSourcePos #-} -instance LineToken Word8 where-  tokenAsChar = chr . fromIntegral-  tokenIsNewline x = x == 10+----------------------------------------------------------------------------+-- Pretty-printing --- | The type class defines how to print custom data component of--- 'ParseError'.+-- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0--class Ord a => ShowErrorComponent a where--  -- | Pretty-print custom data component of 'ParseError'.-+class (Ord a) => ShowErrorComponent a where+  -- | Pretty-print a component of 'ParseError'.   showErrorComponent :: a -> String -instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where-  showErrorComponent (Tokens   ts) = showTokens ts-  showErrorComponent (Label label) = NE.toList label-  showErrorComponent EndOfInput    = "end of input"--instance ShowErrorComponent e => ShowErrorComponent (ErrorFancy e) where-  showErrorComponent (ErrorFail msg) = msg-  showErrorComponent (ErrorIndentation ord ref actual) =-    "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 "-  showErrorComponent (ErrorCustom a) = showErrorComponent a+  -- | 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  instance ShowErrorComponent Void where   showErrorComponent = absurd --- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a--- newline.+-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order, by applying a provided format function, with+-- a single pass over the input stream. ----- @since 5.0.0--parseErrorPretty-  :: ( Ord t-     , ShowToken t-     , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorPretty e =-  sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty e+-- @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 r ""+  where+    f ::+      (ShowS, PosState s) ->+      ParseError s e ->+      (ShowS, PosState s)+    f (o, !pst) e = (o . (outChunk ++), pst')+      where+        (msline, pst') = reachOffset (errorOffset e) pst+        epos = pstateSourcePos pst'+        outChunk = format msline epos e --- | Pretty-print a 'ParseError' and display the line on which the parse--- error occurred. The rendered 'String' always ends with a newline.------ Note that if you work with include files and have a stack of--- 'SourcePos'es in 'ParseError', it's up to you to provide correct input--- stream corresponding to the file in which parse error actually happened.------ 'parseErrorPretty'' is defined in terms of the more general--- 'parseErrorPretty_' function which allows to specify tab width as well:------ > parseErrorPretty' = parseErrorPretty_ defaultTabWidth+-- | 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 6.0.0--parseErrorPretty'-  :: ( ShowToken (Token s)-     , LineToken (Token s)-     , ShowErrorComponent e-     , Stream s )-  => s                 -- ^ Original input stream-  -> ParseError (Token s) e -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorPretty' = parseErrorPretty_ defaultTabWidth+-- @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"+            <> 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+            TrivialError _ Nothing _ -> 1+            TrivialError _ (Just x) _ -> errorItemLength pxy x+            FancyError _ xs ->+              E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs --- | Just like 'parseErrorPretty'', but allows to specify tab width.+-- | 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. ----- @since 6.1.0--parseErrorPretty_-  :: forall s e.-     ( ShowToken (Token s)-     , LineToken (Token s)-     , ShowErrorComponent e-     , Stream s )-  => Pos               -- ^ Tab width-  -> s                 -- ^ Original input stream-  -> ParseError (Token s) e -- ^ Parse error to render-  -> String             -- ^ Result of rendering-parseErrorPretty_ w s e =-  sourcePosStackPretty (errorPos e) <> ":\n" <>-    padding <> "|\n" <>-    lineNumber <> " | " <> rline <> "\n" <>-    padding <> "| " <> rpadding <> "^\n" <>-    parseErrorTextPretty e+-- 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-    epos       = NE.last (errorPos e)-    lineNumber = (show . unPos . sourceLine) epos-    padding    = replicate (length lineNumber + 1) ' '-    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '-    rline      =-      case rline' of-        [] -> "<empty line>"-        xs -> expandTab w xs-    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $-      selectLine (sourceLine epos) s+    format ::+      Maybe String ->+      SourcePos ->+      ParseError s e ->+      String+    format _msline epos e =+      sourcePosPretty epos+        <> ":"+        <> indent (parseErrorTextPretty e) --- | Pretty-print a stack of source positions.+    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--sourcePosStackPretty :: NonEmpty SourcePos -> String-sourcePosStackPretty ms = mconcat (f <$> rest) <> sourcePosPretty pos-  where-    (pos :| rest') = ms-    rest           = reverse rest'-    f p = "in file included from " <> sourcePosPretty p <> ",\n"+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  -- | Pretty-print a textual part of a 'ParseError', that is, everything--- except stack of source positions. The rendered staring always ends with a--- new line.+-- except for its position. The rendered 'String' always ends with a+-- newline. -- -- @since 5.1.0--parseErrorTextPretty-  :: ( Ord t-     , ShowToken t-     , ShowErrorComponent e )-  => ParseError t 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 " (maybe E.empty E.singleton us) <>-         messageItemsPretty "expecting "  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) =   if E.null xs     then "unknown fancy parse error\n"-    else unlines (showErrorComponent <$> E.toAscList xs)+    else unlines (showErrorFancy <$> E.toAscList xs)  ---------------------------------------------------------------------------- -- Helpers --- | @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) <> "\""-  where-    f ch =-      case charPretty' ch of-        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)+-- | Pretty-print an 'ErrorItem'.+--+-- @since 9.4.0+showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String+showErrorItem pxy = \case+  Tokens ts -> showTokens pxy ts+  Label label -> NE.toList label+  EndOfInput -> "end of input" --- | If the given character has a pretty representation, return that,--- otherwise 'Nothing'. This is an internal helper.+-- | Get length of the “pointer” to display under a given 'ErrorItem'.+errorItemLength :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> Int+errorItemLength pxy = \case+  Tokens ts -> tokensLength pxy ts+  _ -> 1 -charPretty' :: Char -> Maybe String-charPretty' '\NUL' = pure "null"-charPretty' '\SOH' = pure "start of heading"-charPretty' '\STX' = pure "start of text"-charPretty' '\ETX' = pure "end of text"-charPretty' '\EOT' = pure "end of transmission"-charPretty' '\ENQ' = pure "enquiry"-charPretty' '\ACK' = pure "acknowledge"-charPretty' '\BEL' = pure "bell"-charPretty' '\BS'  = pure "backspace"-charPretty' '\t'   = pure "tab"-charPretty' '\n'   = pure "newline"-charPretty' '\v'   = pure "vertical tab"-charPretty' '\f'   = pure "form feed"-charPretty' '\r'   = pure "carriage return"-charPretty' '\SO'  = pure "shift out"-charPretty' '\SI'  = pure "shift in"-charPretty' '\DLE' = pure "data link escape"-charPretty' '\DC1' = pure "device control one"-charPretty' '\DC2' = pure "device control two"-charPretty' '\DC3' = pure "device control three"-charPretty' '\DC4' = pure "device control four"-charPretty' '\NAK' = pure "negative acknowledge"-charPretty' '\SYN' = pure "synchronous idle"-charPretty' '\ETB' = pure "end of transmission block"-charPretty' '\CAN' = pure "cancel"-charPretty' '\EM'  = pure "end of medium"-charPretty' '\SUB' = pure "substitute"-charPretty' '\ESC' = pure "escape"-charPretty' '\FS'  = pure "file separator"-charPretty' '\GS'  = pure "group separator"-charPretty' '\RS'  = pure "record separator"-charPretty' '\US'  = pure "unit separator"-charPretty' '\DEL' = pure "delete"-charPretty' '\160' = pure "non-breaking space"-charPretty' _      = Nothing+-- | Pretty-print an 'ErrorFancy'.+showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String+showErrorFancy = \case+  ErrorFail msg -> msg+  ErrorIndentation ord ref actual ->+    "incorrect indentation (got "+      <> show (unPos actual)+      <> ", should be "+      <> p+      <> show (unPos ref)+      <> ")"+    where+      p = case ord of+        LT -> "less than "+        EQ -> "equal to "+        GT -> "greater than "+  ErrorCustom a -> showErrorComponent a --- | Transforms a list of error messages into their textual representation.+-- | Get length of the “pointer” to display under a given 'ErrorFancy'.+errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int+errorFancyLength = \case+  ErrorCustom a -> errorComponentLen a+  _ -> 1 -messageItemsPretty :: ShowErrorComponent a-  => String            -- ^ Prefix to prepend-  -> Set a             -- ^ 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 =-    let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent-    in prefix <> f 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---- | Select a line from input stream given its number.--selectLine-  :: forall s. (LineToken (Token s), Stream s)-  => Pos               -- ^ Number of line to select-  -> s                 -- ^ Input stream-  -> Tokens s          -- ^ Selected line-selectLine l = go pos1-  where-    go !n !s =-      if n == l-        then fst (takeWhile_ notNewline s)-        else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))-    notNewline = not . tokenIsNewline-    stripNewline s =-      case take1_ s of-        Nothing -> s-        Just (_, s') -> s'---- | Replace tab characters with given number of spaces.--expandTab-  :: Pos-  -> String-  -> String-expandTab w' = go 0-  where-    go 0 []        = []-    go 0 ('\t':xs) = go w xs-    go 0 (x:xs)    = x : go 0 xs-    go !n xs       = ' ' : go (n - 1) xs-    w              = unPos w'+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
@@ -0,0 +1,11 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE Safe #-}++module Text.Megaparsec.Error+  ( ParseError,+  )+where++type role ParseError nominal nominal++data ParseError s e
Text/Megaparsec/Error/Builder.hs view
@@ -1,6 +1,14 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module      :  Text.Megaparsec.Error.Builder--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -8,207 +16,177 @@ -- Portability :  portable -- -- A set of helpers that should make construction of 'ParseError's more--- concise. This is primarily useful in test suites and for debugging, you--- most certainly don't need it for normal usage.+-- concise. This is primarily useful in test suites and for debugging. -- -- @since 6.0.0--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Text.Megaparsec.Error.Builder   ( -- * Top-level helpers-    err-  , errFancy-    -- * Error position-  , posI-  , posN+    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.Pos import Text.Megaparsec.Stream-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif- ---------------------------------------------------------------------------- -- Data types  -- | Auxiliary type for construction of trivial parse errors.+data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))+  deriving (Generic) -data ET t = ET (Maybe (ErrorItem t)) (Set (ErrorItem t))-  deriving (Eq, Ord, Data, Typeable, Generic)+deriving instance (Eq (Token s)) => Eq (ET s) -instance Ord t => Semigroup (ET t) where+deriving instance (Ord (Token s)) => Ord (ET s)++deriving instance+  ( Data s,+    Data (Token s),+    Ord (Token s)+  ) =>+  Data (ET s)++instance (Stream s) => Semigroup (ET s) where   ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1)     where-      n Nothing  Nothing = Nothing+      n Nothing Nothing = Nothing       n (Just x) Nothing = Just x       n Nothing (Just y) = Just y       n (Just x) (Just y) = Just (max x y) -instance Ord t => Monoid (ET t) 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.--data EF e = EF (Set (ErrorFancy e))-  deriving (Eq, Ord, Data, Typeable, Generic)+newtype EF e = EF (Set (ErrorFancy e))+  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 source position and @'ET' t@ value. To--- create source position, two helpers are available: 'posI' and 'posN'.--- @'ET' t@ is a monoid and can be assembled by combining primitives--- provided by this module, see below.--err-  :: NonEmpty SourcePos -- ^ 'ParseError' position-  -> ET t              -- ^ Error components-  -> ParseError t e    -- ^ Resulting 'ParseError'-err pos (ET us ps) = TrivialError pos us ps+-- | 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-  :: NonEmpty SourcePos -- ^ 'ParseError' position-  -> EF e              -- ^ Error components-  -> ParseError t e    -- ^ Resulting 'ParseError'-errFancy pos (EF xs) = FancyError pos xs--------------------------------------------------------------------------------- Error position---- | Initial source position with empty file name.--posI :: NonEmpty SourcePos-posI = initialPos "" :| []---- | @'posN' n s@ returns source position achieved by applying 'advanceN'--- method corresponding to the type of stream @s@.--posN :: forall s. Stream s-  => Int-  -> s-  -> NonEmpty SourcePos-posN n s =-  case takeN_ n s of-    Nothing -> posI-    Just (ts, _) ->-      advanceN (Proxy :: Proxy s) defaultTabWidth (initialPos "") ts :| []+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 :: Ord t => t -> ET t+utok :: Token s -> ET s utok = unexp . Tokens . nes --- | Construct an “unexpected tokens” error component. Empty string produces+-- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'.--utoks :: Ord t => [t] -> ET t-utoks = unexp . canonicalizeTokens+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 :: Ord t => String -> ET t-ulabel = unexp . Label . NE.fromList+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 :: Ord t => ET t+ueof :: ET s ueof = unexp EndOfInput  -- | Construct an “expected token” error component.--etok :: Ord t => t -> ET t+etok :: Token s -> ET s etok = expe . Tokens . nes --- | Construct an “expected tokens” error component. Empty string produces+-- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'.--etoks :: Ord t => [t] -> ET t-etoks = expe . canonicalizeTokens+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 :: Ord t => String -> ET t-elabel = expe . Label . NE.fromList+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 :: Ord t => ET t+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 :: [t] -> ErrorItem t-canonicalizeTokens ts =-  case NE.nonEmpty ts of+-- | 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 :: ErrorItem t -> ET t+unexp :: ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty  -- | Lift an expected item into 'ET'.--expe :: ErrorItem t -> ET t+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/Expr.hs 
@@ -1,156 +0,0 @@--- |--- Module      :  Text.Megaparsec.Expr--- Copyright   :  © 2015–2018 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ A helper module to parse expressions. It can build a parser given a table--- of operators.--module Text.Megaparsec.Expr-  ( Operator (..)-  , makeExprParser )-where--import Text.Megaparsec---- | This data type specifies operators that work on values of type @a@. An--- operator is either binary infix or unary prefix or postfix. A binary--- operator has also an associated associativity.--data Operator m a-  = InfixN  (m (a -> a -> a)) -- ^ Non-associative infix-  | InfixL  (m (a -> a -> a)) -- ^ Left-associative infix-  | InfixR  (m (a -> a -> a)) -- ^ Right-associative infix-  | Prefix  (m (a -> a))      -- ^ Prefix-  | Postfix (m (a -> a))      -- ^ Postfix---- | @'makeExprParser' term table@ builds an expression parser for terms--- @term@ with operators from @table@, taking the associativity and--- precedence specified in the @table@ into account.------ @table@ is a list of @[Operator m a]@ lists. The list is ordered in--- descending precedence. All operators in one list have the same precedence--- (but may have different associativity).------ Prefix and postfix operators of the same precedence associate to the left--- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@).------ Unary operators of the same precedence can only occur once (i.e. @--2@ is--- not allowed if @-@ is prefix negate). If you need to parse several prefix--- or postfix operators in a row, (like C pointers—@**i@) you can use this--- approach:------ > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp------ This is not done by default because in some cases allowing repeating--- prefix or postfix operators is not desirable.------ If you want to have an operator that is a prefix of another operator in--- the table, use the following (or similar) wrapper instead of plain--- 'Text.Megaparsec.Char.Lexer.symbol':------ > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar)------ 'makeExprParser' takes care of all the complexity involved in building an--- expression parser. Here is an example of an expression parser that--- handles prefix signs, postfix increment and basic arithmetic:------ > expr = makeExprParser term table <?> "expression"--- >--- > term = parens expr <|> integer <?> "term"--- >--- > table = [ [ prefix  "-"  negate--- >           , prefix  "+"  id ]--- >         , [ postfix "++" (+1) ]--- >         , [ binary  "*"  (*)--- >           , binary  "/"  div  ]--- >         , [ binary  "+"  (+)--- >           , binary  "-"  (-)  ] ]--- >--- > binary  name f = InfixL  (f <$ symbol name)--- > prefix  name f = Prefix  (f <$ symbol name)--- > postfix name f = Postfix (f <$ symbol name)--makeExprParser :: MonadParsec e s m-  => m a               -- ^ Term parser-  -> [[Operator m a]]  -- ^ Operator table, see 'Operator'-  -> m a               -- ^ Resulting expression parser-makeExprParser = foldl addPrecLevel-{-# INLINEABLE makeExprParser #-}---- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@--- to parser @p@.--addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a-addPrecLevel term ops =-  term' >>= \x -> choice [ras' x, las' x, nas' x, return x] <?> "operator"-  where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops-        term' = pTerm (choice prefix) term (choice postfix)-        ras'  = pInfixR (choice ras) term'-        las'  = pInfixL (choice las) term'-        nas'  = pInfixN (choice nas) term'---- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional--- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are--- allowed to fail, in this case 'id' is used.--pTerm :: MonadParsec e s m => m (a -> a) -> m a -> m (a -> a) -> m a-pTerm prefix term postfix = do-  pre  <- option id (hidden prefix)-  x    <- term-  post <- option id (hidden postfix)-  return . post . pre $ x---- | @pInfixN op p x@ parses non-associative infix operator @op@, then term--- with parser @p@, then returns result of the operator application on @x@--- and the term.--pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixN op p x = do-  f <- op-  y <- p-  return $ f x y---- | @pInfixL op p x@ parses left-associative infix operator @op@, then term--- with parser @p@, then returns result of the operator application on @x@--- and the term.--pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixL op p x = do-  f <- op-  y <- p-  let r = f x y-  pInfixL op p r <|> return r---- | @pInfixR op p x@ parses right-associative infix operator @op@, then--- term with parser @p@, then returns result of the operator application on--- @x@ and the term.--pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixR op p x = do-  f <- op-  y <- p >>= \r -> pInfixR op p r <|> return r-  return $ f x y--type Batch m a =-  ( [m (a -> a -> a)]-  , [m (a -> a -> a)]-  , [m (a -> a -> a)]-  , [m (a -> a)]-  , [m (a -> a)] )---- | A helper to separate various operators (binary, unary, and according to--- associativity) and return them in a tuple.--splitOp :: Operator m a -> Batch m a -> Batch m a-splitOp (InfixR  op) (r, l, n, pre, post) = (op:r, l, n, pre, post)-splitOp (InfixL  op) (r, l, n, pre, post) = (r, op:l, n, pre, post)-splitOp (InfixN  op) (r, l, n, pre, post) = (r, l, op:n, pre, post)-splitOp (Prefix  op) (r, l, n, pre, post) = (r, l, n, op:pre, post)-splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post)
Text/Megaparsec/Internal.hs view
@@ -1,6 +1,19 @@+{-# 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–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -13,66 +26,53 @@ -- rely on these unless you really know what you're doing. -- -- @since 6.5.0--{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}--#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)-{-# OPTIONS -Wno-noncanonical-monoid-instances #-}-#endif- module Text.Megaparsec.Internal   ( -- * Data types-    Hints (..)-  , Reply (..)-  , Consumption (..)-  , Result (..)-  , ParsecT (..)+    Hints (..),+    Reply (..),+    Consumption (..),+    Result (..),+    ParsecT (..),+     -- * Helper functions-  , toHints-  , withHints-  , accHints-  , refreshLastHint-  , runParsecT )+    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 hiding (state)+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 hiding (option)+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.Pos 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  -- | 'Hints' represent a collection of 'ErrorItem's to be included into--- 'ParserError' (when it's a 'TrivialError') as “expected” message items+-- 'ParseError' (when it's a 'TrivialError') as “expected” message items -- when a parser fails without consuming input right after successful parser -- that produced the hints. --@@ -83,82 +83,83 @@ -- unexpected 'a' -- expecting end of input ----- We're getting better error messages with help of hints:+-- We're getting better error messages with the help of hints: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 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) Consumption (Result (Token s) e a)+data Reply e s a = Reply (State s e) Consumption (Result s e a)+  deriving (Functor) --- | This data structure represents an aspect of result of parser's work.+-- | 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 --- | This data structure represents an aspect of result of parser's work.+-- | 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 t e a-  = OK a                   -- ^ Parser succeeded-  | Error (ParseError t e) -- ^ Parser failed+data Result s e a+  = -- | 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-      -> (a -> State s   -> Hints (Token s) -> m b) -- consumed-OK-      -> (ParseError (Token s) e -> State s -> m b) -- consumed-error-      -> (a -> State s   -> Hints (Token s) -> m b) -- empty-OK-      -> (ParseError (Token s) e -> State s -> 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 (<>) #-}-#if MIN_VERSION_base(4,8,0)   sconcat = fmap sconcat . sequence-#else-  sconcat = fmap (sconcat . NE.fromList) . sequence . NE.toList-#endif   {-# INLINE sconcat #-}  -- | @since 5.3.0- instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where   mempty = pure mempty   {-# INLINE mempty #-}-#if MIN_VERSION_base(4,11,0)   mappend = (<>)-#else-  mappend = liftA2 mappend-#endif   {-# INLINE mappend #-}   mconcat = fmap mconcat . sequence   {-# 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@@ -170,332 +171,425 @@ {-# 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-  fail   = Fail.fail+  (>>=) = 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 _ pos _ _) _ _ _ eerr ->+pFail msg = ParsecT $ \s@(State _ o _ _) _ _ _ eerr ->   let d = E.singleton (ErrorFail msg)-  in eerr (FancyError pos 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 -> 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  pZero :: ParsecT e s m a-pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (TrivialError pos Nothing E.empty) s+pZero = ParsecT $ \s@(State _ o _ _) _ _ _ eerr ->+  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 (statePos 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 #-} --- | @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"-    runParsecT (f a) s- -- | 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 -> State s -> State s-longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) =-  case tp1 `compare` tp2 of+longestMatch :: State s e -> State s e -> State s e+longestMatch s1@(State _ o1 _ _) s2@(State _ o2 _ _) =+  case o1 `compare` o2 of     LT -> s2     EQ -> s2     GT -> s1 {-# INLINE longestMatch #-} -instance MonadTrans (ParsecT e s) where+-- | @since 6.0.0+instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where+  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 (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-  failure           = pFailure-  fancyFailure      = pFancyFailure-  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--pFailure-  :: Maybe (ErrorItem (Token s))-  -> Set (ErrorItem (Token s))-  -> ParsecT e s m a-pFailure us ps = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (TrivialError pos us ps) s-{-# INLINE pFailure #-}+  mkParsec = pmkParsec -pFancyFailure-  :: Set (ErrorFancy e)-  -> ParsecT e s m a-pFancyFailure xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (FancyError pos xs) s-{-# INLINE pFancyFailure #-}+pParseError ::+  ParseError s e ->+  ParsecT e s m a+pParseError e = ParsecT $ \s _ _ _ eerr -> eerr e s+{-# INLINE pParseError #-}  pLabel :: String -> ParsecT e s m a -> ParsecT e s m a pLabel l p = ParsecT $ \s cok cerr eok eerr ->   let el = Label <$> NE.nonEmpty l-      cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l-      cok' x s' hs = cok x s' (refreshLastHint hs cl)-      eok' x s' hs = eok x s' (refreshLastHint hs el)-      eerr'    err = eerr $+      cok' x s' hs =+        case el of+          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 p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr ->+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 pos (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-  :: (ParseError (Token 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-            reok x s' _ = eok x s' (toHints (statePos s') err)-            reerr   _ _ = cerr err ms-        in unParser (r err) ms rcok rcerr reok reerr+            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       meerr err ms =-        let rcok x s' _ = cok x s' (toHints (statePos s') err)-            rcerr   _ _ = eerr err ms-            reok x s' _ = eok x s' (toHints (statePos s') err)-            reerr   _ _ = eerr err ms-        in unParser (r err) ms rcok rcerr reok reerr-  in unParser p s cok mcerr eok meerr+        let rcok x s' _ = cok x s' (toHints (stateOffset s') err)+            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 {-# INLINE pWithRecovery #-} -pObserving-  :: ParsecT e s m a-  -> ParsecT e s m (Either (ParseError (Token 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 (statePos s') err)-  in unParser p s (cok . Right) cerr' (eok . Right) eerr'+      eerr' err s' = eok (Left err) s' (toHints (stateOffset s') err)+   in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} -pEof :: forall e s m. Stream s => ParsecT e s m ()-pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr ->+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,_) ->-      let !apos = positionAt1 (Proxy :: Proxy s) pos x-          us    = (pure . Tokens . nes) x-          ps    = E.singleton EndOfInput-      in eerr (TrivialError (apos:|z) us ps)-          (State input (apos:|z) tp w)+    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) {-# INLINE pEof #-} -pToken :: forall e s m a. Stream s-  => (Token s -> Either ( Maybe (ErrorItem (Token s))-                        , Set (ErrorItem (Token s)) ) a)-  -> Maybe (Token s)-  -> ParsecT e s m a-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->+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-          ps = maybe E.empty (E.singleton . Tokens . nes) mtoken-      in eerr (TrivialError (pos:|z) us ps) s-    Just (c,cs) ->+       in eerr (TrivialError o us ps) s+    Just (c, cs) ->       case test c of-        Left (us, ps) ->-          let !apos = positionAt1 (Proxy :: Proxy s) pos c-          in eerr (TrivialError (apos:|z) us ps)-                  (State input (apos:|z) tp w)-        Right x ->-          let !npos = advance1 (Proxy :: Proxy s) w pos c-              newstate = State cs (npos:|z) (tp + 1) w-          in cok x newstate mempty+        Nothing ->+          let us = (Just . Tokens . nes) c+           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 f tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ eok eerr ->+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 (pos:|z) EndOfInput) s-    Just (tts', input') ->-      if f tts tts'-        then let !npos = advanceN pxy w pos tts'-                 st    = State input' (npos:|z) (tp + len) w-             in if chunkEmpty pxy tts-                  then eok tts' st mempty-                  else cok tts' st mempty-        else let !apos = positionAtN pxy pos tts'-                 ps = (Tokens . NE.fromList . chunkToTokens pxy) tts'-             in eerr (unexpect (apos:|z) ps) (State input (apos:|z) tp w)+   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 ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ eok _ ->+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-      !npos = advanceN pxy w pos ts       len = chunkLength pxy ts       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' (npos:|z) (tp + len) w) hs-       else cok ts (State input' (npos:|z) (tp + len) w) 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 ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ _ eerr ->+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       len = chunkLength pxy ts@@ -503,46 +597,49 @@       hs =         case el of           Nothing -> mempty-          Just l -> (Hints . pure . E.singleton) l-  in if chunkEmpty pxy ts-       then let !apos = positionAtN pxy pos ts-                us    = pure $-                  case take1_ input of-                    Nothing -> EndOfInput-                    Just (t,_) -> Tokens (nes t)-                ps    = maybe E.empty E.singleton el-            in eerr (TrivialError (apos:|z) us ps)-                    (State input (apos:|z) tp w)-       else let !npos = advanceN pxy w pos ts-            in cok ts (State input' (npos:|z) (tp + len) w) 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 (pos:|z) tp w) 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 (pos:|z) (pure EndOfInput) ps) s-       Just (ts, input') ->-         let len   = chunkLength pxy ts-             !apos = positionAtN pxy pos ts-             !npos = advanceN pxy w pos ts-         in if len /= n-           then eerr (TrivialError (npos:|z) (pure EndOfInput) ps)-                     (State input (apos:|z) tp w)-           else cok ts (State input' (npos:|z) (tp + len) w) 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)+pGetParserState :: (Stream s) => ParsecT e s m (State s e) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s -> State s) -> 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 #-} @@ -553,70 +650,118 @@ ---------------------------------------------------------------------------- -- Helper functions --- | Convert 'ParseError' record into 'Hints'.--toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t+-- | 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 errPos _ ps ->+  TrivialError errOffset _ ps ->     -- NOTE This is important to check here that the error indeed has     -- happened at the same position as current position of stream because     -- there might have been backtracking with 'try' and in that case we     -- must not convert such a parse error to hints.-    if streamPos == errPos-      then Hints (if E.null ps then [] else [ps])+    if streamPos == errOffset+      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@.+-- | @'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 :: Ord (Token s)-  => Hints (Token s)   -- ^ Hints to use-  -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence-  -> ParseError (Token s) e -- ^ First argument of resulting continuation-  -> State s           -- ^ 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 -> Hints t -> m b) -- ^ An “OK” continuation to alter-  -> a                 -- ^ First argument of resulting continuation-  -> State s           -- ^ Second argument of resulting continuation-  -> Hints t           -- ^ Third argument of resulting continuation-  -> m b+-- | @'accHints' hs c@ results in “OK” continuation that will add given+-- hints @hs@ to third argument of original continuation @c@.+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 '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       -- ^ 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 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.+  (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 = []+            }+        adjustState :: State s e -> State s e'+        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'+{-# 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
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Common token combinators. This module is not public, the functions from+-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char".+--+-- @since 7.0.0+module Text.Megaparsec.Lexer+  ( -- * White space+    space,+    lexeme,+    symbol,+    symbol',+  )+where++import qualified Data.CaseInsensitive as CI+import Text.Megaparsec+import Text.Megaparsec.Common++----------------------------------------------------------------------------+-- White space++-- | @'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+-- '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.+--+-- @blockComment@ is used to parse block (multi-line) comments. You can use+-- @skipBlockComment@ or @skipBlockCommentNested@ if you don't need anything+-- special.+--+-- If you don't want to allow a kind of comment, simply pass 'empty' which+-- 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) =>+  -- | 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. 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) =>+  -- | How to consume white space after lexeme+  m () ->+  -- | How to parse actual lexeme+  m a ->+  m a+lexeme spc p = p <* spc+{-# INLINEABLE lexeme #-}++-- | This is a helper to parse symbols, i.e. verbatim strings. You pass the+-- first argument (parser that consumes white space, probably defined via+-- 'space') and then you can use the resulting function to parse strings:+--+-- > symbol    = L.symbol spaceConsumer+-- >+-- > parens    = between (symbol "(") (symbol ")")+-- > braces    = between (symbol "{") (symbol "}")+-- > angles    = between (symbol "<") (symbol ">")+-- > brackets  = between (symbol "[") (symbol "]")+-- > semicolon = symbol ";"+-- > comma     = symbol ","+-- > colon     = symbol ":"+-- > dot       = symbol "."+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 #-}++-- | 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)) =>+  -- | 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/Perm.hs 
@@ -1,146 +0,0 @@--- |--- Module      :  Text.Megaparsec.Perm--- Copyright   :  © 2015–2018 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ This module implements permutation parsers. The algorithm is described--- in: /Parsing Permutation Phrases/, by Arthur Baars, Andres Loh and--- Doaitse Swierstra. Published as a functional pearl at the Haskell--- Workshop 2001.--{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}--module Text.Megaparsec.Perm-  ( PermParser-  , makePermParser-  , (<$$>)-  , (<$?>)-  , (<||>)-  , (<|?>) )-where--import Text.Megaparsec--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--infixl 1 <||>, <|?>-infixl 2 <$$>, <$?>---- | The type @PermParser s m a@ denotes a permutation parser that, when--- converted by the 'makePermParser' function, produces instance of--- 'MonadParsec' @m@ that parses @s@ stream and returns a value of type @a@--- on success.------ Normally, a permutation parser is first build with special operators like--- ('<||>') and than transformed into a normal parser using--- 'makePermParser'.--data PermParser s m a = Perm (Maybe a) [Branch s m a]--data Branch s m a = forall b. Branch (PermParser s m (b -> a)) (m b)---- | The parser @makePermParser perm@ parses a permutation of parser--- described by @perm@. For example, suppose we want to parse a permutation--- of: an optional string of @a@'s, the character @b@ and an optional @c@.--- This can be described by:------ > test = makePermParser $--- >          (,,) <$?> ("", some (char 'a'))--- >               <||> char 'b'--- >               <|?> ('_', char 'c')--makePermParser :: MonadParsec e s m-  => PermParser s m a -- ^ Given permutation parser-  -> m a              -- ^ Normal parser built from it-makePermParser (Perm def xs) = choice (fmap branch xs ++ empty')-  where empty' =-          case def of-            Nothing -> []-            Just x  -> [return x]-        branch (Branch perm p) = flip ($) <$> p <*> makePermParser perm---- | The expression @f \<$$> p@ creates a fresh permutation parser--- consisting of parser @p@. The the final result of the permutation parser--- is the function @f@ applied to the return value of @p@. The parser @p@ is--- not allowed to accept empty input—use the optional combinator ('<$?>')--- instead.------ If the function @f@ takes more than one parameter, the type variable @b@--- is instantiated to a functional type which combines nicely with the adds--- parser @p@ to the ('<||>') combinator. This results in stylized code--- where a permutation parser starts with a combining function @f@ followed--- by the parsers. The function @f@ gets its parameters in the order in--- which the parsers are specified, but actual input can be in any order.--(<$$>) :: MonadParsec e s m-  => (a -> b)          -- ^ Function to use on result of parsing-  -> m a               -- ^ Normal parser-  -> PermParser s m b  -- ^ Permutation parser build from it-f <$$> p = newperm f <||> p---- | The expression @f \<$?> (x, p)@ creates a fresh permutation parser--- consisting of parser @p@. The final result of the permutation parser is--- the function @f@ applied to the return value of @p@. The parser @p@ is--- optional—if it cannot be applied, the default value @x@ will be used--- instead.--(<$?>) :: MonadParsec e s m-  => (a -> b)          -- ^ Function to use on result of parsing-  -> (a, m a)          -- ^ Default value and parser-  -> PermParser s m b  -- ^ Permutation parser-f <$?> xp = newperm f <|?> xp---- | The expression @perm \<||> p@ adds parser @p@ to the permutation parser--- @perm@. The parser @p@ is not allowed to accept empty input—use the--- optional combinator ('<|?>') instead. Returns a new permutation parser--- that includes @p@.--(<||>) :: MonadParsec e s m-  => PermParser s m (a -> b) -- ^ Given permutation parser-  -> m a               -- ^ Parser to add (should not accept empty input)-  -> PermParser s m b  -- ^ Resulting parser-(<||>) = add---- | The expression @perm \<||> (x, p)@ adds parser @p@ to the permutation--- parser @perm@. The parser @p@ is optional—if it cannot be applied, the--- default value @x@ will be used instead. Returns a new permutation parser--- that includes the optional parser @p@.--(<|?>) :: MonadParsec e s m-  => PermParser s m (a -> b) -- ^ Given permutation parser-  -> (a, m a)          -- ^ Default value and parser-  -> PermParser s m b  -- ^ Resulting parser-perm <|?> (x, p) = addopt perm x p--newperm :: (a -> b) -> PermParser s m (a -> b)-newperm f = Perm (Just f) []--add :: MonadParsec e s m => PermParser s m (a -> b) -> m a -> PermParser s m b-add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs)-  where first = Branch perm p-        insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p'--addopt :: MonadParsec e s m-  => PermParser s m (a -> b)-  -> a-  -> m a-  -> PermParser s m b-addopt perm@(Perm mf fs) x p = Perm (fmap ($ x) mf) (first : fmap insert fs)-  where first   = Branch perm p-        insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p'--mapPerms :: MonadParsec e s m-  => (a -> b)-  -> PermParser s m a-  -> PermParser s m b-mapPerms f (Perm x xs) = Perm (fmap f x) (fmap mapBranch xs)-  where mapBranch (Branch perm p) = Branch (mapPerms (f .) perm) p
Text/Megaparsec/Pos.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}+ -- | -- Module      :  Text.Megaparsec.Pos--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -8,41 +13,31 @@ -- Portability :  portable -- -- Textual source position. The position includes name of file, line number,--- and column number. List of such positions can be used to model a stack of--- include files.+-- and column number. -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway.--{-# LANGUAGE CPP                        #-}-{-# 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 -#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif- ---------------------------------------------------------------------------- -- Abstract position @@ -52,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@@ -71,7 +64,6 @@ -- | Extract 'Int' from 'Pos'. -- -- @since 6.0.0- unPos :: Pos -> Int unPos (Pos w) = w {-# INLINE unPos #-}@@ -79,7 +71,6 @@ -- | Position with value 1. -- -- @since 6.0.0- pos1 :: Pos pos1 = mkPos 1 @@ -87,8 +78,11 @@ -- you want to refer to the default tab width because actual value /may/ -- change in future. --+-- Currently:+--+-- > defaultTabWidth = mkPos 8+-- -- @since 5.0.0- defaultTabWidth :: Pos defaultTabWidth = mkPos 8 @@ -100,22 +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--data InvalidPosException = InvalidPosException Int-  -- ^ The first value is the minimal allowed value, the second value is 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 @@ -123,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,6 +1,13 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module      :  Text.Megaparsec.State--- Copyright   :  © 2015–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -12,34 +19,115 @@ -- Definition of Megaparsec's 'State'. -- -- @since 6.5.0--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}- module Text.Megaparsec.State-  ( State (..) )+  ( State (..),+    initialState,+    PosState (..),+    initialPosState,+  ) where  import Control.DeepSeq (NFData) import Data.Data (Data)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Typeable (Typeable) import GHC.Generics+import {-# SOURCE #-} Text.Megaparsec.Error (ParseError) import Text.Megaparsec.Pos --- | This is the Megaparsec's state parametrized over stream type @s@.--data State s = State-  { stateInput :: s-    -- ^ The rest of input to process-  , statePos :: NonEmpty SourcePos-    -- ^ Current position (column + line number) with support for include files-  , stateTokensProcessed :: {-# UNPACK #-} !Int-    -- ^ Number of processed tokens so far+-- | This is the Megaparsec's state parametrized over stream type @s@ and+-- custom error component type @e@.+data State s e = State+  { -- | The rest of input to process+    stateInput :: s,+    -- | Number of processed tokens so far     ---    -- @since 5.2.0-  , stateTabWidth :: Pos-    -- ^ Tab width to use-  } deriving (Show, Eq, Data, Typeable, Generic)+    -- @since 7.0.0+    stateOffset :: {-# UNPACK #-} !Int,+    -- | State that is used for line\/column calculation+    --+    -- @since 7.0.0+    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+    stateParseErrors :: [ParseError s e]+  }+  deriving (Generic) -instance NFData s => NFData (State s)+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+  ( Data e,+    Data (ParseError s e),+    Data s+  ) =>+  Data (State s e)++instance (NFData s, NFData (ParseError s e)) => NFData (State s e)++-- | Given the name of the source file and the input construct the initial+-- state for a parser.+--+-- @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+  { -- | 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)++-- | 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,6 +1,18 @@+{-# 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–2018 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -13,41 +25,52 @@ -- "Text.Megaparsec" re-exports it anyway. -- -- @since 6.0.0--{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies      #-}- module Text.Megaparsec.Stream-  ( Stream (..) )+  ( Stream (..),+    ShareInput (..),+    NoShareInput (..),+    VisualStream (..),+    TraversableStream (..),+  ) where -import Data.List (foldl')+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 (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 Data.Semigroup ((<>))+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 qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text            as T-import qualified Data.Text.Lazy       as TL--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif+import Text.Megaparsec.State+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 Token s :: Type    -- | Type of “chunk” of the stream.--  type Tokens s :: *+  type Tokens s :: Type    -- | Lift a single token to chunk of the stream. The default   -- implementation is:@@ -56,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@@ -84,61 +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-  {-# INLINE chunkEmpty #-} -  -- | Set source position __at__ given token. By default, the given-  -- 'SourcePos' (second argument) is just returned without looking at the-  -- token. This method is important when your stream is a collection of-  -- tokens where every token knows where it begins in the original input.--  positionAt1-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> SourcePos       -- ^ Position of the token-  positionAt1 Proxy = defaultPositionAt-  {-# INLINE positionAt1 #-}--  -- | The same as 'positionAt1', but for chunks of the stream. The function-  -- should return the position where the entire chunk begins. Again, by-  -- default the second argument is returned without modifications and the-  -- chunk is not looked at.--  positionAtN-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> SourcePos       -- ^ Current position-    -> Tokens s        -- ^ Current chunk-    -> SourcePos       -- ^ Position of the chunk-  positionAtN Proxy = defaultPositionAt-  {-# INLINE positionAtN #-}--  -- | Advance position given a single token. The returned position is the-  -- position right after the token, or the position where the token ends.--  advance1-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> SourcePos       -- ^ Advanced position--  -- | Advance position given a chunk of stream. The returned position is-  -- the position right after the chunk, or the position where the chunk-  -- ends.--  advanceN-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Tokens s        -- ^ Current token-    -> SourcePos       -- ^ Advanced position-   -- | 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@@ -154,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@@ -163,124 +131,649 @@   -- 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) -instance Stream String where-  type Token String = Char-  type Tokens String = String+-- | @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-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = foldl' (defaultAdvance1 w)   take1_ [] = Nothing-  take1_ (t:ts) = Just (t, ts)+  take1_ (t : ts) = Just (t, ts)   takeN_ n s-    | n <= 0    = Just ("", s)-    | null s    = Nothing+    | n <= 0 = Just ([], s)+    | null s = Nothing     | otherwise = Just (splitAt n s)   takeWhile_ = span -instance Stream B.ByteString where-  type Token B.ByteString = Word8-  type Tokens B.ByteString = B.ByteString+-- | @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-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = B.foldl' (defaultAdvance1 w)-  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+  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 BL.ByteString where-  type Token BL.ByteString = Word8-  type Tokens BL.ByteString = BL.ByteString+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-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = BL.foldl' (defaultAdvance1 w)-  take1_ = BL.uncons-  takeN_ n s-    | n <= 0    = Just (BL.empty, s)+  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 (BL.splitAt (fromIntegral n) s)-  takeWhile_ = BL.span+    | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s+  takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s -instance Stream T.Text where-  type Token T.Text = Char-  type Tokens T.Text = T.Text+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-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = T.foldl' (defaultAdvance1 w)-  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+  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 TL.Text where-  type Token TL.Text  = Char-  type Tokens TL.Text = TL.Text+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-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = TL.foldl' (defaultAdvance1 w)-  take1_ = TL.uncons-  takeN_ n s-    | n <= 0    = Just (TL.empty, s)+  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 (TL.splitAt (fromIntegral n) s)-  takeWhile_ = TL.span+    | 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+  -- spans. The default implementation is sufficient if every token spans+  -- 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):+  --+  --     * '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@.+  --+  -- The 'String' representing the offending line in input stream should+  -- satisfy the following:+  --+  --     * It should adequately represent location of token at the offset of+  --       interest, that is, character at 'sourceColumn' of the returned+  --       'SourcePos' should correspond to the token at the offset @o@.+  --     * It should not include the newline at the end.+  --     * It should not be empty, if the line happens to be empty, it+  --       should be replaced with the string @\"\<empty line\>\"@.+  --     * Tab characters should be replaced by appropriate number of+  --       spaces, which is determined by the 'pstateTabWidth' field of+  --       'PosState'.+  --+  -- __Note__: type signature of the function was changed in the version+  -- /9.0.0/.+  --+  -- @since 7.0.0+  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.+  --+  -- The default implementation is this:+  --+  -- > reachOffsetNoLine o pst =+  -- >   snd (reachOffset o pst)+  --+  -- __Note__: type signature of the function was changed in the version+  -- /8.0.0/.+  --+  -- @since 7.0.0+  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 TraversableStream String where+  -- NOTE Do not eta-reduce these (breaks inlining)+  reachOffset o pst =+    reachOffset' splitAt Data.List.foldl' id id ('\n', '\t') charInc o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAt Data.List.foldl' ('\n', '\t') charInc o pst++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) byteInc o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' B.splitAt B.foldl' (10, 9) byteInc o pst++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) byteInc o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) byteInc o pst++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') charInc o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') charInc o pst++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') charInc o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') charInc o pst+ ---------------------------------------------------------------------------- -- Helpers --- | Default positioning function designed to work with simple streams where--- tokens do not contain info about their position in the stream. Thus it--- just returns the given 'SourcePos' without re-positioning.+-- | An internal helper state type combining a difference 'String' and an+-- unboxed 'SourcePos'.+data St = St {-# UNPACK #-} !SourcePos ShowS -defaultPositionAt :: SourcePos -> a -> SourcePos-defaultPositionAt pos _ = pos-{-# INLINE defaultPositionAt #-}+-- | 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'+  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' #-} --- | Update a source position given a token. The first argument specifies--- the tab width. If the character is a newline (\'\\n\') the line number is--- incremented by 1 and column number is reset to 1. If the character is a--- tab (\'\\t\') the column number is incremented to the nearest tab--- position. In all other cases, the column is incremented by 1.+-- | 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'+  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' #-} -defaultAdvance1 :: Enum t-  => Pos               -- ^ Tab width-  -> SourcePos         -- ^ Current position-  -> t                 -- ^ Current token-  -> SourcePos         -- ^ Incremented position-defaultAdvance1 width (SourcePos n l c) t = npos+-- | 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) <> "\""   where-    w  = unPos width-    c' = unPos c-    npos =-      case fromEnum t of-        10 -> SourcePos n (l <> pos1) pos1-        9  -> SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))-        _  -> SourcePos n l (c <> pos1)-{-# INLINE defaultAdvance1 #-}+    f ch =+      case charPretty' ch of+        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"+  '\SOH' -> Just "start of heading"+  '\STX' -> Just "start of text"+  '\ETX' -> Just "end of text"+  '\EOT' -> Just "end of transmission"+  '\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"+  '\DLE' -> Just "data link escape"+  '\DC1' -> Just "device control one"+  '\DC2' -> Just "device control two"+  '\DC3' -> Just "device control three"+  '\DC4' -> Just "device control four"+  '\NAK' -> Just "negative acknowledge"+  '\SYN' -> Just "synchronous idle"+  '\ETB' -> Just "end of transmission block"+  '\CAN' -> Just "cancel"+  '\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"+  '\DEL' -> Just "delete"+  '\160' -> Just "non-breaking space"+  _ -> Nothing++-- | Replace tab characters with given number of spaces.+expandTab ::+  Pos ->+  String ->+  String+expandTab w' = go 0 0+  where+    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,43 +1,51 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Main (main) where  import Control.DeepSeq import Control.Monad-import Data.Semigroup ((<>))+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.Text                  as T import qualified Text.Megaparsec.Char.Lexer as L---- | 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'))@@ -46,54 +54,174 @@   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) --- | Perform a series of measurements with the same parser.+  forM_ stdSeries $ \n ->+    bbundle "single error" n [n] -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 ()+  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 of measurements with the same parser.+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-  func (name ++ "/" ++ show i) p' arg+  let arg = (f i, i)+      p' (s, n) = parse (p (s, n)) "" s+  func (name ++ "-" ++ show i) p' arg --- | The series of sizes to try as part of 'bparser'.+-- | 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 +-- | 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' :| ""))+      bundle :: ParseErrorBundle String Void+      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++-- | 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 = ""+            }++-- | 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 = ""+          }++-- | 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,103 +1,221 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Main (main) where  import Control.DeepSeq import Criterion.Main-import Data.Semigroup ((<>))+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.Text                  as T import qualified Text.Megaparsec.Char.Lexer as L -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif---- | The type of parser that consumes 'String's.-+-- | 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 = 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)-  ]+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 --- | The series of sizes to try as part of 'bparser'.+-- | 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 +-- | 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' :| ""))+      bundle :: ParseErrorBundle String Void+      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)++-- | 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 = ""+            }++-- | 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 = ""+          }++-- | 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,155 +1,127 @@-name:                 megaparsec-version:              6.5.0-cabal-version:        1.18-tested-with:          GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.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 strikes 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:      AUTHORS.md-                    , 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.7   && < 5.0-                    , bytestring   >= 0.2   && < 0.11-                    , case-insensitive >= 1.2 && < 1.3-                    , containers   >= 0.5   && < 0.6-                    , deepseq      >= 1.3   && < 1.5-                    , mtl          >= 2.0   && < 3.0-                    , parser-combinators >= 0.4 && < 1.0-                    , scientific   >= 0.3.1 && < 0.4-                    , text         >= 0.2   && < 1.3-                    , transformers >= 0.4   && < 0.6-  if !impl(ghc >= 8.0)-    build-depends:    fail         == 4.9.*-                    , semigroups   == 0.18.*-  if !impl(ghc >= 7.10)-    build-depends:    void         == 0.7.*-  exposed-modules:    Text.Megaparsec-                    , Text.Megaparsec.Byte-                    , Text.Megaparsec.Byte.Lexer-                    , Text.Megaparsec.Char-                    , Text.Megaparsec.Char.Lexer-                    , Text.Megaparsec.Error-                    , Text.Megaparsec.Error.Builder-                    , Text.Megaparsec.Expr-                    , Text.Megaparsec.Internal-                    , Text.Megaparsec.Perm-                    , Text.Megaparsec.Pos-                    , Text.Megaparsec.Stream-  other-modules:      Text.Megaparsec.Class-                    , Text.Megaparsec.State-  if flag(dev)-    ghc-options:      -O0 -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  if flag(dev) && impl(ghc >= 8.0)-    ghc-options:      -Wcompat-                      -Wincomplete-record-updates-                      -Wincomplete-uni-patterns-                      -Wnoncanonical-monad-instances-                      -Wnoncanonical-monadfail-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 -test-suite tests-  main-is:            Main.hs-  hs-source-dirs:     tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -O0 -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  other-modules:      Spec-                    , Control.Applicative.CombinatorsSpec-                    , Control.Monad.CombinatorsSpec-                    , Test.Hspec.Megaparsec-                    , Test.Hspec.Megaparsec.AdHoc-                    , Text.Megaparsec.Byte.LexerSpec-                    , Text.Megaparsec.ByteSpec-                    , Text.Megaparsec.Char.LexerSpec-                    , Text.Megaparsec.CharSpec-                    , Text.Megaparsec.ErrorSpec-                    , Text.Megaparsec.ExprSpec-                    , Text.Megaparsec.PermSpec-                    , Text.Megaparsec.PosSpec-                    , Text.Megaparsec.StreamSpec-                    , Text.MegaparsecSpec-  build-depends:      QuickCheck   >= 2.7   && < 2.12-                    , base         >= 4.7   && < 5.0-                    , bytestring   >= 0.2   && < 0.11-                    , containers   >= 0.5   && < 0.6-                    , hspec        >= 2.0   && < 3.0-                    , hspec-expectations >= 0.5 && < 0.9-                    , megaparsec-                    , mtl          >= 2.0   && < 3.0-                    , scientific   >= 0.3.1 && < 0.4-                    , text         >= 0.2   && < 1.3-                    , transformers >= 0.4   && < 0.6-  build-tools:        hspec-discover >= 2.0 && < 3.0-  if !impl(ghc >= 8.0)-    build-depends:    semigroups   == 0.18.*-  if !impl(ghc >= 7.10)-    build-depends:    void         == 0.7.*-  default-language:   Haskell2010+    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.7  && < 5.0-                    , criterion    >= 0.6.2.1 && < 1.5-                    , deepseq      >= 1.3  && < 1.5-                    , megaparsec-                    , text         >= 0.2  && < 1.3-  if !impl(ghc >= 8.0)-    build-depends:    semigroups   == 0.18.*-  if !impl(ghc >= 7.10)-    build-depends:    void         == 0.7.*-  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.7  && < 5.0-                    , deepseq      >= 1.3  && < 1.5-                    , megaparsec-                    , text         >= 0.2  && < 1.3-                    , weigh        >= 0.0.4-  if !impl(ghc >= 8.0)-    build-depends:    semigroups   == 0.18.*-  if !impl(ghc >= 7.10)-    build-depends:    void         == 0.7.*-  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
− tests/Control/Applicative/CombinatorsSpec.hs 
@@ -1,286 +0,0 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE MultiWayIf #-}--module Control.Applicative.CombinatorsSpec (spec) where--import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#endif--spec :: Spec-spec = do--  describe "between" $-    it "works" . property $ \pre c n' post -> do-      let p = between (string pre) (string post) (many (char c))-          n = getNonNegative n'-          b = length (takeWhile (== c) post)-          z = replicate n c-          s = pre ++ z ++ post-      if b > 0-        then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s)-          ( etoks post <> etok c <>-            if length post == b-              then ueof-              else utoks (drop b post) )-        else prs_ p s `shouldParse` z--  describe "choice" $-    it "works" . property $ \cs' s' -> do-      let cs = getNonEmpty cs'-          p = choice (char <$> cs)-          s = [s']-      if s' `elem` cs-        then prs_ p s `shouldParse` s'-        else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs))--  describe "count" $ do-    it "works" . property $ \n x' -> do-      let x = getNonNegative x'-          p = count n (char 'x')-          p' = count' n n (char 'x')-          s = replicate x 'x'-      prs_ p s `shouldBe` prs_ p' s-    rightOrder (count 3 letterChar) "abc" "abc"--  describe "count'" $ do-    it "works" . property $ \m n x' -> do-      let x = getNonNegative x'-          p = count' m n (char 'x')-          s = replicate x 'x'-      if | n <= 0 || m > n ->-           if x == 0-             then prs_ p s `shouldParse` ""-             else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)-         | m <= x && x <= n ->-           prs_ p s `shouldParse` s-         | x < m ->-           prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)-    rightOrder (count' 1 3 letterChar) "abc" "abc"--  describe "eitherP" $-    it "works" . property $ \ch -> do-      let p = eitherP letterChar digitChar-          s = pure ch-      if | isLetter ch -> prs_ p s `shouldParse` Left ch-         | isDigit  ch -> prs_ p s `shouldParse` Right ch-         | otherwise   -> prs_ p s `shouldFailWith`-           err posI (utok ch <> elabel "letter" <> elabel "digit")--  describe "endBy" $ do-    it "works" . property $ \n' c -> do-      let n = getNonNegative n'-          p = endBy (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ [c]-      if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-         | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-         | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)-         | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             ( utok c <>-               (if n > 0 then etok '-' else eeof) <>-               (if n == 0 then etok 'a' else mempty) )-         | otherwise -> prs_ p s `shouldParse` replicate n 'a'-    rightOrder (endBy letterChar (char ',')) "a,b,c," "abc"--  describe "endBy1" $ do-    it "works" . property $ \n' c -> do-      let n = getNonNegative n'-          p = endBy1 (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ [c]-      if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-         | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-         | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')-         | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             ( utok c <>-               (if n > 0 then etok '-' else mempty) <>-               (if n == 0 then etok 'a' else mempty) )-         | otherwise -> prs_ p s `shouldParse` replicate n 'a'-    rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc"--  describe "manyTill" $ do-    it "works" . property $ \a' b' c' -> do-      let [a,b,c] = getNonNegative <$> [a',b',c']-          p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar-          s = abcRow a b c-      if c == 0-        then prs_ p s `shouldFailWith` err (posN (a + b) s)-             (ueof <> etok 'c' <> elabel "letter")-        else let (pre, post) = break (== 'c') s-             in prs_ p s `shouldParse` (pre, drop 1 post)-    rightOrder (manyTill letterChar (char 'd')) "abcd" "abc"--  describe "someTill" $ do-    it "works" . property $ \a' b' c' -> do-      let [a,b,c] = getNonNegative <$> [a',b',c']-          p = (,) <$> someTill letterChar (char 'c') <*> many letterChar-          s = abcRow a b c-      if | null s ->-           prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")-         | c == 0 ->-           prs_ p s `shouldFailWith` err (posN (a + b) s)-             (ueof <> etok 'c' <> elabel "letter")-         | s == "c" ->-           prs_ p s `shouldFailWith` err-             (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")-         | head s == 'c' ->-           prs_ p s `shouldParse` ("c", drop 2 s)-         | otherwise ->-           let (pre, post) = break (== 'c') s-           in prs_ p s `shouldParse` (pre, drop 1 post)-    rightOrder (someTill letterChar (char 'd')) "abcd" "abc"--  describe "option" $-    it "works" . property $ \d a s -> do-      let p = option d (string a)-          p' = fromMaybe d <$> optional (string a)-      prs_ p s `shouldBe` prs_ p' s--  describe "sepBy" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepBy (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' ->-           prs_ p s `shouldParse` replicate n 'a'-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI-             (utok c <> etok 'a' <> eeof)-         | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s)-             (ueof <> etok 'a')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             (utok c <> etok '-' <> eeof)-    rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"--  describe "sepBy1" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepBy1 (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' && n >= 1 ->-           prs_ p s `shouldParse` replicate n 'a'-         | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-         | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"--  describe "sepEndBy" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepEndBy (char 'a') (char '-')-          a = replicate n 'a'-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' ->-           prs_ p s `shouldParse` a-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)-         | c == '-' ->-           prs_ p s `shouldParse` a-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"--  describe "sepEndBy1" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepEndBy1 (char 'a') (char '-')-          a = replicate n 'a'-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' && n >= 1 ->-           prs_ p s `shouldParse` a-         | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-         | c == '-' ->-           prs_ p s `shouldParse` a-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"--  describe "skipMany" $-    it "works" . property $ \c n' a -> do-      let p = skipMany (char c) *> string a-          n = getNonNegative n'-          p' = many (char c) >> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipSome" $-    it "works" . property $ \c n' a -> do-      let p = skipSome (char c) *> string a-          n = getNonNegative n'-          p' = some (char c) >> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipCount" $-    it "works" . property $ \c n' a -> do-      let p = skipCount n (char c) *> string a-          n = getNonNegative n'-          p' = count n (char c) *> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipManyTill" $-    it "works" . property $ \c n' a -> c /= a ==> do-      let p = skipManyTill (char c) (char a)-          n = getNonNegative n'-          s = replicate n c ++ [a]-      prs_ p s `shouldParse` a--  describe "skipSomeTill" $-    it "works" . property $ \c n' a -> c /= a ==> do-      let p = skipSomeTill (char c) (char a)-          n = getNonNegative n'-          s = replicate n c ++ [a]-      if n == 0-        then prs_ p s `shouldFailWith` err posI (utok a <> etok c)-        else prs_ p s `shouldParse` a--------------------------------------------------------------------------------- Helpers--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0
− tests/Control/Monad/CombinatorsSpec.hs 
@@ -1,246 +0,0 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE MultiWayIf #-}--module Control.Monad.CombinatorsSpec (spec) where--import Data.List (intersperse)-import Data.Maybe (maybeToList, isNothing, fromJust)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#endif--spec :: Spec-spec = do--  describe "count" $ do-    it "works" . property $ \n x' -> do-      let x = getNonNegative x'-          p = count n (char 'x')-          p' = count' n n (char 'x')-          s = replicate x 'x'-      prs_ p s `shouldBe` prs_ p' s-    rightOrder (count 3 letterChar) "abc" "abc"--  describe "count'" $ do-    it "works" . property $ \m n x' -> do-      let x = getNonNegative x'-          p = count' m n (char 'x')-          s = replicate x 'x'-      if | n <= 0 || m > n ->-           if x == 0-             then prs_ p s `shouldParse` ""-             else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)-         | m <= x && x <= n ->-           prs_ p s `shouldParse` s-         | x < m ->-           prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)-    rightOrder (count' 1 3 letterChar) "abc" "abc"--  describe "endBy" $ do-    it "works" . property $ \n' c -> do-      let n = getNonNegative n'-          p = endBy (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ [c]-      if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-         | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-         | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)-         | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             ( utok c <>-               (if n > 0 then etok '-' else eeof) <>-               (if n == 0 then etok 'a' else mempty) )-         | otherwise -> prs_ p s `shouldParse` replicate n 'a'-    rightOrder (endBy letterChar (char ',')) "a,b,c," "abc"--  describe "endBy1" $ do-    it "works" . property $ \n' c -> do-      let n = getNonNegative n'-          p = endBy1 (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ [c]-      if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-         | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-         | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')-         | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             ( utok c <>-               (if n > 0 then etok '-' else mempty) <>-               (if n == 0 then etok 'a' else mempty) )-         | otherwise -> prs_ p s `shouldParse` replicate n 'a'-    rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc"--  describe "manyTill" $ do-    it "works" . property $ \a' b' c' -> do-      let [a,b,c] = getNonNegative <$> [a',b',c']-          p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar-          s = abcRow a b c-      if c == 0-        then prs_ p s `shouldFailWith` err (posN (a + b) s)-             (ueof <> etok 'c' <> elabel "letter")-        else let (pre, post) = break (== 'c') s-             in prs_ p s `shouldParse` (pre, drop 1 post)-    rightOrder (manyTill letterChar (char 'd')) "abcd" "abc"--  describe "someTill" $ do-    it "works" . property $ \a' b' c' -> do-      let [a,b,c] = getNonNegative <$> [a',b',c']-          p = (,) <$> someTill letterChar (char 'c') <*> many letterChar-          s = abcRow a b c-      if | null s ->-           prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")-         | c == 0 ->-           prs_ p s `shouldFailWith` err (posN (a + b) s)-             (ueof <> etok 'c' <> elabel "letter")-         | s == "c" ->-           prs_ p s `shouldFailWith` err-             (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")-         | head s == 'c' ->-           prs_ p s `shouldParse` ("c", drop 2 s)-         | otherwise ->-           let (pre, post) = break (== 'c') s-           in prs_ p s `shouldParse` (pre, drop 1 post)-    rightOrder (someTill letterChar (char 'd')) "abcd" "abc"--  describe "sepBy" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepBy (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' ->-           prs_ p s `shouldParse` replicate n 'a'-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI-             (utok c <> etok 'a' <> eeof)-         | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s)-             (ueof <> etok 'a')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             (utok c <> etok '-' <> eeof)-    rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"--  describe "sepBy1" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepBy1 (char 'a') (char '-')-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' && n >= 1 ->-           prs_ p s `shouldParse` replicate n 'a'-         | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-         | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"--  describe "sepEndBy" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepEndBy (char 'a') (char '-')-          a = replicate n 'a'-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' ->-           prs_ p s `shouldParse` a-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)-         | c == '-' ->-           prs_ p s `shouldParse` a-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"--  describe "sepEndBy1" $ do-    it "works" . property $ \n' c' -> do-      let n = getNonNegative n'-          c = fromJust c'-          p = sepEndBy1 (char 'a') (char '-')-          a = replicate n 'a'-          s = intersperse '-' (replicate n 'a') ++ maybeToList c'-      if | isNothing c' && n >= 1 ->-           prs_ p s `shouldParse` a-         | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-         | c == 'a' && n == 0 ->-           prs_ p s `shouldParse` "a"-         | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-         | c == '-' ->-           prs_ p s `shouldParse` a-         | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)-    rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"--  describe "skipMany" $-    it "works" . property $ \c n' a -> do-      let p = skipMany (char c) *> string a-          n = getNonNegative n'-          p' = many (char c) >> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipSome" $-    it "works" . property $ \c n' a -> do-      let p = skipSome (char c) *> string a-          n = getNonNegative n'-          p' = some (char c) >> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipCount" $-    it "works" . property $ \c n' a -> do-      let p = skipCount n (char c) *> string a-          n = getNonNegative n'-          p' = count n (char c) *> string a-          s = replicate n c ++ a-      prs_ p s `shouldBe` prs_ p' s--  describe "skipManyTill" $-    it "works" . property $ \c n' a -> c /= a ==> do-      let p = skipManyTill (char c) (char a)-          n = getNonNegative n'-          s = replicate n c ++ [a]-      prs_ p s `shouldParse` a--  describe "skipSomeTill" $-    it "works" . property $ \c n' a -> c /= a ==> do-      let p = skipSomeTill (char c) (char a)-          n = getNonNegative n'-          s = replicate n c ++ [a]-      if n == 0-        then prs_ p s `shouldFailWith` err posI (utok a <> etok c)-        else prs_ p s `shouldParse` a--------------------------------------------------------------------------------- Helpers--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0
− tests/Main.hs 
@@ -1,7 +0,0 @@-module Main (main) where--import Test.Hspec.Runner-import Spec (spec)--main :: IO ()-main = hspecWith defaultConfig { configQuickCheckMaxSuccess = Just 1000 } spec
− tests/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
− tests/Test/Hspec/Megaparsec.hs 
@@ -1,211 +0,0 @@--- |--- Module      :  Test.Hspec.Megaparsec--- Copyright   :  © 2016–2017 Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Utility functions for testing Megaparsec parsers with Hspec.--{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}--module Test.Hspec.Megaparsec-  ( -- * Basic expectations-    shouldParse-  , parseSatisfies-  , shouldSucceedOn-  , shouldFailOn-    -- * Testing of error messages-  , shouldFailWith-    -- * Incremental parsing-  , failsLeaving-  , succeedsLeaving-  , initialState-    -- * Re-exports-  , module Text.Megaparsec.Error.Builder )-where--import Control.Monad (unless)-import Data.List.NonEmpty (NonEmpty (..))-import Test.Hspec.Expectations-import Text.Megaparsec-import Text.Megaparsec.Error.Builder--------------------------------------------------------------------------------- Basic expectations---- | Create an expectation by saying what the result should be.------ > parse letterChar "" "x" `shouldParse` 'x'--shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a)-  => Either (ParseError t e) a-     -- ^ Result of parsing as returned by function like 'parse'-  -> a                 -- ^ Desired result-  -> Expectation-r `shouldParse` v = case r of-  Left e -> expectationFailure $ "expected: " ++ show v ++-    "\nbut parsing failed with error:\n" ++ showParseError e-  Right x -> unless (x == v) . expectationFailure $-    "expected: " ++ show v ++ "\nbut got: " ++ show x---- | Create an expectation by saying that the parser should successfully--- parse a value and that the value should satisfy some predicate.------ > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length)--parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a-     -- ^ Result of parsing as returned by function like 'parse'-  -> (a -> Bool)       -- ^ Predicate-  -> Expectation-r `parseSatisfies` p = case r of-  Left e -> expectationFailure $-    "expected a parsed value to check against the predicate" ++-    "\nbut parsing failed with error:\n" ++ showParseError e-  Right x -> unless (p x) . expectationFailure $-    "the value did not satisfy the predicate: " ++ show x---- | Check that a parser fails on a given input.------ > parse (char 'x') "" `shouldFailOn` "a"--shouldFailOn :: Show a-  => (s -> Either (ParseError t e) a)-     -- ^ Parser that takes stream and produces result or error message-  -> s                 -- ^ Input that the parser should fail on-  -> Expectation-p `shouldFailOn` s = shouldFail (p s)---- | Check that a parser succeeds on a given input.------ > parse (char 'x') "" `shouldSucceedOn` "x"--shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => (s -> Either (ParseError t e) a)-     -- ^ Parser that takes stream and produces result or error message-  -> s                 -- ^ Input that the parser should succeed on-  -> Expectation-p `shouldSucceedOn` s = shouldSucceed (p s)--------------------------------------------------------------------------------- Testing of error messages---- | Create an expectation that parser should fail producing certain--- 'ParseError'. Use the 'err' function from this module to construct a--- 'ParseError' to compare with.------ > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x')--shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a-  -> ParseError t e-  -> Expectation-r `shouldFailWith` e = case r of-  Left e' -> unless (e == e') . expectationFailure $-    "the parser is expected to fail with:\n" ++ showParseError e ++-    "but it failed with:\n" ++ showParseError e'-  Right v -> expectationFailure $-    "the parser is expected to fail, but it parsed: " ++ show v--------------------------------------------------------------------------------- Incremental parsing---- | Check that a parser fails and leaves a certain part of input--- unconsumed. Use it with functions like 'runParser'' and 'runParserT''--- that support incremental parsing.------ > runParser' (many (char 'x') <* eof) (initialState "xxa")--- >   `failsLeaving` "a"------ See also: 'initialState'.--failsLeaving :: (Show a, Eq s, Show s, Stream s)-  => (State s, Either (ParseError (Token s) e) a)-     -- ^ Parser that takes stream and produces result along with actual-     -- state information-  -> s                 -- ^ Part of input that should be left unconsumed-  -> Expectation-(st,r) `failsLeaving` s =-  shouldFail r >> checkUnconsumed s (stateInput st)---- | Check that a parser succeeds and leaves certain part of input--- unconsumed. Use it with functions like 'runParser'' and 'runParserT''--- that support incremental parsing.------ > runParser' (many (char 'x')) (initialState "xxa")--- >   `succeedsLeaving` "a"------ See also: 'initialState'.--succeedsLeaving :: ( ShowToken (Token s)-                   , ShowErrorComponent e-                   , Show a-                   , Eq s-                   , Show s-                   , Stream s )-  => (State s, Either (ParseError (Token s) e) a)-     -- ^ Parser that takes stream and produces result along with actual-     -- state information-  -> s                 -- ^ Part of input that should be left unconsumed-  -> Expectation-(st,r) `succeedsLeaving` s =-  shouldSucceed r >> checkUnconsumed s (stateInput st)---- | Given input for parsing, construct initial state for parser (that is,--- with empty file name, default tab width and position at 1 line and 1--- column).--initialState :: s -> State s-initialState s = State-  { stateInput           = s-  , statePos             = initialPos "" :| []-  , stateTokensProcessed = 0-  , stateTabWidth        = defaultTabWidth }--------------------------------------------------------------------------------- Helpers---- | Expectation that argument is result of a failed parser.--shouldFail :: Show a-  => Either (ParseError t e) a-  -> Expectation-shouldFail r = case r of-  Left _ -> return ()-  Right v -> expectationFailure $-    "the parser is expected to fail, but it parsed: " ++ show v---- | Expectation that argument is result of a succeeded parser.--shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a-  -> Expectation-shouldSucceed r = case r of-  Left e -> expectationFailure $-    "the parser is expected to succeed, but it failed with:\n" ++-    showParseError e-  Right _ -> return ()---- | Compare two streams for equality and in the case of mismatch report it.--checkUnconsumed :: (Eq s, Show s, Stream s)-  => s                 -- ^ Expected unconsumed input-  -> s                 -- ^ Actual unconsumed input-  -> Expectation-checkUnconsumed e a = unless (e == a) . expectationFailure $-  "the parser is expected to leave unconsumed input: " ++ show e ++-  "\nbut it left this: " ++ show a---- | Render parse error in a way that is suitable for inserting it in a test--- suite report.--showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)-  => ParseError t e-  -> String-showParseError = unlines . fmap ("  " ++) . lines . parseErrorPretty
− tests/Test/Hspec/Megaparsec/AdHoc.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE RankNTypes           #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Test.Hspec.Megaparsec.AdHoc-  ( -- * Helpers to run parsers-    prs-  , prs'-  , prs_-  , grs-  , grs'-    -- * Working with source position-  , updatePosString-  , pos1-  , nes-    -- * Other-  , abcRow-  , toFirstMismatch-  , rightOrder-  , Parser )-where--import Control.Monad-import Control.Monad.Reader-import Control.Monad.Trans.Identity-import Data.List.NonEmpty (NonEmpty (..))-import Data.Proxy-import Data.Void-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.QuickCheck-import Text.Megaparsec-import qualified Control.Monad.RWS.Lazy      as L-import qualified Control.Monad.RWS.Strict    as S-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.ByteString             as B-import qualified Data.ByteString.Lazy        as BL-import qualified Data.List.NonEmpty          as NE-import qualified Data.Set                    as E-import qualified Data.Text                   as T-import qualified Data.Text.Lazy              as TL--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--------------------------------------------------------------------------------- Helpers to run parsers---- | Apply parser to given input. This is a specialized version of 'parse'--- that assumes empty file name.--prs-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Void) a -- ^ Result of parsing-prs p = parse p ""---- | Just like 'prs', but allows to inspect the final state of the parser.--prs'-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> (State String, Either (ParseError Char Void) a) -- ^ Result of parsing-prs' p s = runParser' p (initialState s)---- | Just like 'prs', but forces the parser to consume all input by adding--- 'eof':------ > prs_ p = parse (p <* eof) ""--prs_-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Void) a -- ^ Result of parsing-prs_ p = parse (p <* eof) ""---- | Just like 'prs', but interprets given parser as various monads (tries--- all supported monads transformers in turn).--grs-  :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> (Either (ParseError Char Void) a -> Expectation)-    -- ^ How to check result of parsing-  -> Expectation-grs p s r = do-  r (prs p s)-  r (prs (runIdentityT p)    s)-  r (prs (runReaderT   p ()) s)-  r (prs (L.evalStateT p ()) s)-  r (prs (S.evalStateT p ()) s)-  r (prs (evalWriterTL p)    s)-  r (prs (evalWriterTS p)    s)-  r (prs (evalRWSTL    p)    s)-  r (prs (evalRWSTS    p)    s)---- | 'grs'' to 'grs' is as 'prs'' to 'prs'.--grs'-  :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> ((State String, Either (ParseError Char Void) a) -> Expectation)-    -- ^ How to check result of parsing-  -> Expectation-grs' p s r = do-  r (prs' p s)-  r (prs' (runIdentityT p)    s)-  r (prs' (runReaderT   p ()) s)-  r (prs' (L.evalStateT p ()) s)-  r (prs' (S.evalStateT p ()) s)-  r (prs' (evalWriterTL p)    s)-  r (prs' (evalWriterTS p)    s)-  r (prs' (evalRWSTL    p)    s)-  r (prs' (evalRWSTS    p)    s)--evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a-evalWriterTL = liftM fst . L.runWriterT-evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a-evalWriterTS = liftM fst . S.runWriterT--evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a-evalRWSTL m = do-  (a,_,_) <- L.runRWST m () ()-  return a--evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a-evalRWSTS m = do-  (a,_,_) <- S.runRWST m () ()-  return a--------------------------------------------------------------------------------- Working with source position---- | A helper function that is used to advance 'SourcePos' given a 'String'.--updatePosString-  :: Pos               -- ^ Tab width-  -> SourcePos         -- ^ Initial position-  -> String            -- ^ 'String' — collection of tokens to process-  -> SourcePos         -- ^ Final position-updatePosString = advanceN (Proxy :: Proxy String)---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []--------------------------------------------------------------------------------- Other---- | @abcRow a b c@ generates string consisting of character “a” repeated--- @a@ times, character “b” repeated @b@ times, and character “c” repeated--- @c@ times.--abcRow :: Int -> Int -> Int -> String-abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c'---- | Given a comparing function, get prefix of one string till first--- mismatch with another string (including first mismatching character).--toFirstMismatch-  :: (Char -> Char -> Bool) -- ^ Comparing function-  -> String            -- ^ First string-  -> String            -- ^ Second string-  -> String            -- ^ Resulting prefix-toFirstMismatch f str s = take (n + 1) s-  where n = length (takeWhile (uncurry f) (zip str s))---- | Check that the given parser returns the list in the right order.--rightOrder-  :: Parser String     -- ^ The parser to test-  -> String            -- ^ Input for the parser-  -> String            -- ^ Expected result-  -> Spec-rightOrder p s s' =-  it "produces the list in the right order" $-    prs_ p s `shouldParse` s'---- | The type of parser that consumes a 'String'.--type Parser = Parsec Void String--------------------------------------------------------------------------------- Arbitrary instances--instance Arbitrary Void where-  arbitrary = error "Arbitrary Void"--instance Arbitrary Pos where-  arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))--instance Arbitrary SourcePos where-  arbitrary = SourcePos-    <$> sized (\n -> do-          k <- choose (0, n `div` 2)-          vectorOf k arbitrary)-    <*> arbitrary-    <*> arbitrary--instance Arbitrary t => Arbitrary (ErrorItem t) where-  arbitrary = oneof-    [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , return EndOfInput ]--instance Arbitrary (ErrorFancy a) where-  arbitrary = oneof-    [ sized (\n -> do-        k <- choose (0, n `div` 2)-        ErrorFail <$> vectorOf k arbitrary)-    , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]--instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where-  arbitrary = oneof-    [ TrivialError-      <$> (NE.fromList . getNonEmpty <$> arbitrary)-      <*> arbitrary-      <*> (E.fromList <$> arbitrary)-    , FancyError-      <$> (NE.fromList . getNonEmpty <$> arbitrary)-      <*> (E.fromList <$> arbitrary) ]--instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State-    <$> arbitrary-    <*> (NE.fromList . getNonEmpty <$> arbitrary)-    <*> choose (1, 10000)-    <*> (mkPos <$> choose (1, 20))--instance Arbitrary T.Text where-  arbitrary = T.pack <$> arbitrary--instance Arbitrary TL.Text where-  arbitrary = TL.pack <$> arbitrary--instance Arbitrary B.ByteString where-  arbitrary = B.pack <$> arbitrary--instance Arbitrary BL.ByteString where-  arbitrary = BL.pack <$> arbitrary--#if MIN_VERSION_QuickCheck(2,10,0)-instance Arbitrary a => Arbitrary (NonEmpty a) where-  arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null))-#endif
− tests/Text/Megaparsec/Byte/LexerSpec.hs 
@@ -1,287 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.Byte.LexerSpec (spec) where--import Control.Applicative-import Data.ByteString (ByteString)-import Data.Char (toUpper)-import Data.Monoid ((<>))-import Data.Scientific (Scientific, fromFloatDigits)-import Data.Void-import Data.Word (Word8)-import Numeric (showInt, showHex, showOct, showFFloatAlt)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Byte.Lexer-import qualified Data.ByteString       as B-import qualified Data.ByteString.Char8 as B8-import qualified Text.Megaparsec.Byte  as B--type Parser = Parsec Void ByteString--spec :: Spec-spec = do--  describe "skipLineComment" $ do-    context "when there is no newline at the end of line" $-      it "is picked up successfully" $ do-        let p = space B.space1 (skipLineComment "//") empty <* eof-            s = "  // this line comment doesn't have a newline at the end "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""-    it "inner characters are labelled properly" $ do-      let p = skipLineComment "//" <* empty-          s = "// here we go"-      prs  p s `shouldFailWith` err (posN (B.length s) s) (elabel "character")-      prs' p s `failsLeaving` ""--  describe "skipBlockComment" $-    it "skips a simple block comment" $ do-      let p = skipBlockComment "/*" "*/"-          s = "/* here we go */foo!"-      prs  p s `shouldParse` ()-      prs' p s `succeedsLeaving` "foo!"--  describe "skipBlockCommentNested" $-    context "when it runs into nested block comments" $-      it "parses them all right" $ do-        let p = space B.space1 empty-              (skipBlockCommentNested "/*" "*/") <* eof-            s = " /* foo bar /* baz */ quux */ "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""--  describe "decimal" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = decimal :: Parser Integer-              n = getNonNegative n'-              s = B8.pack (showInt n "")-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with decimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = decimal :: Parser Integer-              s = B.pack (a : as)-          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (decimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "integer")--  describe "octal" $ do-    context "when stream begins with octal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = octal :: Parser Integer-              n = getNonNegative n'-              s = B8.pack (showOct n "")-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with octal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isOctDigit a) ==> do-          let p = octal :: Parser Integer-              s = B.pack (a : as)-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "octal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (octal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")--  describe "hexadecimal" $ do-    context "when stream begins with hexadecimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = hexadecimal :: Parser Integer-              n = getNonNegative n'-              s = B8.pack (showHex n "")-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream begins with hexadecimal digits (uppercase)" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = hexadecimal :: Parser Integer-              n = getNonNegative n'-              s = B8.pack (toUpper <$> showHex n "")-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with hexadecimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isHexDigit a) ==> do-          let p = hexadecimal :: Parser Integer-              s = B.pack (a : as)-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "hexadecimal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (hexadecimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")--  describe "scientific" $ do-    context "when stream begins with a number" $-      it "parses it" $-        property $ \n' -> do-          let p = scientific :: Parser Scientific-              s = B8.pack $ either (show . getNonNegative) (show . getNonNegative)-                (n' :: Either (NonNegative Integer) (NonNegative Double))-          prs p s `shouldParse` case n' of-            Left  x -> fromIntegral    (getNonNegative x)-            Right x -> fromFloatDigits (getNonNegative x)-          prs' p s `succeedsLeaving` ""-    context "when fractional part is interrupted" $-      it "signals correct parse error" $-        property $ \(NonNegative n) -> do-          let p = scientific <* empty :: Parser Scientific-              s = B8.pack (showFFloatAlt Nothing (n :: Double) "")-          prs p s `shouldFailWith` err (posN (B.length s) s)-            (etok 69 <> etok 101 <> elabel "digit")-          prs' p s `failsLeaving` ""-    context "when whole part is followed by a dot without valid fractional part" $-      it "parsing of fractional part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = scientific :: Parser Scientific-              s = B8.pack $ showInt (n :: Integer) ".err"-          prs  p s `shouldParse` fromIntegral n-          prs' p s `succeedsLeaving` ".err"-    context "when number is followed by something starting with 'e'" $-      it "parsing of exponent part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = scientific :: Parser Scientific-              s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"-          prs  p s `shouldParse` fromFloatDigits n-          prs' p s `succeedsLeaving` "err!"-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (scientific :: Parser Scientific) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")--  describe "float" $ do-    context "when stream begins with a float" $-      it "parses it" $-        property $ \n' -> do-          let p = float :: Parser Double-              n = getNonNegative n'-              s = B8.pack (show n)-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with a float" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = float :: Parser Double-              s = B.pack (a : as)-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "digit")-          prs' p s `failsLeaving` s-    context "when stream begins with an integer (decimal)" $-      it "signals correct parse error" $-        property $ \n' -> do-          let p = float :: Parser Double-              n = getNonNegative n'-              s = B8.pack $ show (n :: Integer)-          prs  p s `shouldFailWith` err (posN (B.length s) s)-            (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit")-          prs' p s `failsLeaving` ""-    context "when number is followed by something starting with 'e'" $-      it "parsing of exponent part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = float :: Parser Double-              s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` "err!"-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (float :: Parser Double) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")-    context "when there is float with just exponent" $-      it "parses it all right" $ do-        let p = float :: Parser Double-        prs  p "123e3" `shouldParse` 123e3-        prs' p "123e3" `succeedsLeaving` ""-        prs  p "123e+3" `shouldParse` 123e+3-        prs' p "123e+3" `succeedsLeaving` ""-        prs  p "123e-3" `shouldParse` 123e-3-        prs' p "123e-3" `succeedsLeaving` ""--  describe "signed" $ do-    context "with integer" $-      it "parses signed integers" $-        property $ \n -> do-          let p :: Parser Integer-              p = signed (hidden B.space) decimal-              s = B8.pack (show n)-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with float" $-      it "parses signed floats" $-        property $ \n -> do-          let p :: Parser Double-              p = signed (hidden B.space) float-              s = B8.pack (show n)-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with scientific" $-      it "parses singed scientific numbers" $-        property $ \n -> do-          let p = signed (hidden B.space) scientific-              s = B8.pack $ either show show (n :: Either Integer Double)-          prs p s `shouldParse` case n of-            Left  x -> fromIntegral    x-            Right x -> fromFloatDigits x-    context "when number is prefixed with plus sign" $-      it "parses the number" $-        property $ \n' -> do-          let p :: Parser Integer-              p = signed (hidden B.space) decimal-              n = getNonNegative n'-              s = B8.pack ('+' : show n)-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when number is prefixed with white space" $-      it "signals correct parse error" $-        property $ \n -> do-          let p :: Parser Integer-              p = signed (hidden B.space) decimal-              s = B8.pack (' ' : show (n :: Integer))-          prs  p s `shouldFailWith` err posI-            (utok 32 <> etok 43 <> etok 45 <> elabel "integer")-          prs' p s `failsLeaving` s-    context "when there is white space between sign and digits" $-      it "parses it all right" $ do-        let p :: Parser Integer-            p = signed (hidden B.space) decimal-            s = "- 123"-        prs  p s `shouldParse` (-123)-        prs' p s `succeedsLeaving` ""--------------------------------------------------------------------------------- Helpers--prs-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> Either (ParseError Word8 Void) a -- ^ Result of parsing-prs p = parse p ""--prs'-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing-prs' p s = runParser' p (initialState s)--isDigit :: Word8 -> Bool-isDigit w = w - 48 < 10--isOctDigit :: Word8 -> Bool-isOctDigit w = w - 48 < 8--isHexDigit :: Word8 -> Bool-isHexDigit w =-  (w >= 48 && w <= 57)  ||-  (w >= 97 && w <= 102) ||-  (w >= 65 && w <= 70)
− tests/Text/Megaparsec/ByteSpec.hs 
@@ -1,251 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.ByteSpec (spec) where--import Control.Monad-import Data.ByteString (ByteString)-import Data.Char-import Data.Maybe (fromMaybe)-import Data.Proxy-import Data.Semigroup ((<>))-import Data.Void-import Data.Word (Word8)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc (nes)-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Byte-import qualified Data.ByteString as B--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--type Parser = Parsec Void ByteString--spec :: Spec-spec = do--  describe "newline" $-    checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline)--  describe "csrf" $-    checkStrLit "crlf newline" "\r\n" crlf--  describe "eol" $ do-    context "when stream begins with a newline" $-      it "succeeds returning the newline" $-        property $ \s -> do-          let s' = "\n" <> s-          prs  eol s' `shouldParse`     "\n"-          prs' eol s' `succeedsLeaving` s-    context "when stream begins with CRLF sequence" $-      it "parses the CRLF sequence" $-        property $ \s -> do-          let s' = "\r\n" <> s-          prs  eol s' `shouldParse`     "\r\n"-          prs' eol s' `succeedsLeaving` s-    context "when stream begins with '\\r', but it's not followed by '\\n'" $-      it "signals correct parse error" $-        property $ \ch -> ch /= 10 ==> do-          let s = "\r" <> B.singleton ch-          prs eol s `shouldFailWith`-            err posI (utoks (B.unpack s) <> elabel "end of line")-    context "when input stream is '\\r'" $-      it "signals correct parse error" $-        prs eol "\r" `shouldFailWith` err posI-          (utok 13 <> elabel "end of line")-    context "when stream does not begin with newline or CRLF sequence" $-      it "signals correct parse error" $-        property $ \ch s -> (ch /= 13 && ch /= 10) ==> do-          let s' = B.singleton ch <> s-          prs eol s' `shouldFailWith` err posI-            (utoks (B.unpack $ B.take 2 s') <> elabel "end of line")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs eol "" `shouldFailWith` err posI-          (ueof <> elabel "end of line")--  describe "tab" $-    checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)--  describe "space" $-    it "consumes space up to first non-space character" $-      property $ \s' -> do-        let (s0,s1) = B.partition isSpace' s'-            s = s0 <> s1-        prs  space s `shouldParse` ()-        prs' space s `succeedsLeaving` s1--  describe "space1" $ do-    context "when stream does not start with a space character" $-      it "signals correct parse error" $-        property $ \ch s' -> not (isSpace' ch) ==> do-          let (s0,s1) = B.partition isSpace' s'-              s = B.singleton ch <> s0 <> s1-          prs  space1 s `shouldFailWith` err posI (utok ch <> elabel "white space")-          prs' space1 s `failsLeaving` s-    context "when stream starts with a space character" $-      it "consumes space up to first non-space character" $-        property $ \s' -> do-          let (s0,s1) = B.partition isSpace' s'-              s = " " <> s0 <> s1-          prs  space1 s `shouldParse` ()-          prs' space1 s `succeedsLeaving` s1-    context "when stream is empty" $-      it "signals correct parse error" $-        prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space")--  describe "controlChar" $-    checkCharPred "control character" (isControl . toChar) controlChar--  describe "spaceChar" $-    checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar--  -- describe "upperChar" $-  --   checkCharPred "uppercase letter" (isUpper . toChar) upperChar--  -- describe "lowerChar" $-  --   checkCharPred "lowercase letter" (isLower . toChar) lowerChar--  -- describe "letterChar" $-  --   checkCharPred "letter" (isAlpha . toChar) letterChar--  describe "alphaNumChar" $-    checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar--  describe "printChar" $-    checkCharPred "printable character" (isPrint . toChar) printChar--  describe "digitChar" $-    checkCharRange "digit" [48..57] digitChar--  describe "octDigitChar" $-    checkCharRange "octal digit" [48..55] octDigitChar--  describe "hexDigitChar" $-    checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar--  -- describe "asciiChar" $-  --   checkCharPred "ASCII character" (isAscii . toChar) asciiChar--  describe "char'" $ do-    context "when stream begins with the character specified as argument" $-      it "parses the character" $-        property $ \ch s -> do-          let sl = B.cons (liftChar toLower ch) s-              su = B.cons (liftChar toUpper ch) s-          prs  (char' ch) sl `shouldParse`     liftChar toLower ch-          prs  (char' ch) su `shouldParse`     liftChar toUpper ch-          prs' (char' ch) sl `succeedsLeaving` s-          prs' (char' ch) su `succeedsLeaving` s-    context "when stream does not begin with the character specified as argument" $-      it "signals correct parse error" $-        property $ \ch ch' s -> liftChar toLower ch /= liftChar toLower ch' ==> do-          let s' = B.cons ch' s-              ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)-          prs  (char' ch) s' `shouldFailWith` err posI ms-          prs' (char' ch) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \ch -> do-          let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)-          prs  (char' ch) "" `shouldFailWith` err posI ms--------------------------------------------------------------------------------- Helpers--checkStrLit :: String -> ByteString -> Parser ByteString -> SpecWith ()-checkStrLit name ts p = do-  context ("when stream begins with " ++ name) $-    it ("parses the " ++ name) $-      property $ \s -> do-        let s' = ts <> s-        prs  p s' `shouldParse`     ts-        prs' p s' `succeedsLeaving` s-  context ("when stream does not begin with " ++ name) $-    it "signals correct parse error" $-      property $ \ch s -> ch /= B.head ts ==> do-       let s' = B.cons ch s-           us = B.unpack $ B.take (B.length ts) s'-           ps = B.unpack ts-       prs  p s' `shouldFailWith` err posI (utoks us <> etoks ps)-       prs' p s' `failsLeaving`   s'-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> etoks (B.unpack ts))--checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith ()-checkCharPred name f p = do-  context ("when stream begins with " ++ name) $-    it ("parses the " ++ name) $-      property $ \ch s -> f ch ==> do-        let s' = B.singleton ch <> s-        prs  p s' `shouldParse`     ch-        prs' p s' `succeedsLeaving` s-  context ("when stream does not begin with " ++ name) $-    it "signals correct parse error" $-      property $ \ch s -> not (f ch) ==> do-       let s' = B.singleton ch <> s-       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)-       prs' p s' `failsLeaving`   s'-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)--checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith ()-checkCharRange name tchs p = do-  forM_ tchs $ \tch ->-    context ("when stream begins with " ++ showTokens (nes tch)) $-      it ("parses the " ++ showTokens (nes tch)) $-        property $ \s -> do-          let s' = B.singleton tch <> s-          prs  p s' `shouldParse`     tch-          prs' p s' `succeedsLeaving` s-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)--prs-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> Either (ParseError Word8 Void) a -- ^ Result of parsing-prs p = parse p ""--prs'-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing-prs' p s = runParser' p (initialState s)--bproxy :: Proxy ByteString-bproxy = Proxy---- | 'Word8'-specialized version of 'isSpace'.--isSpace' :: Word8 -> Bool-isSpace' x-  | x >= 9 && x <= 13 = True-  | x == 32           = True-  | x == 160          = True-  | otherwise         = False---- | Convert a byte to char.--toChar :: Word8 -> Char-toChar = chr . fromIntegral---- | Covert a char to byte.--fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in-  if p > 0xff-    then Nothing-    else Just (fromIntegral p)---- | Lift char transformation to byte transformation.--liftChar :: (Char -> Char) -> Word8 -> Word8-liftChar f x = (fromMaybe x . fromChar . f . toChar) x
− tests/Text/Megaparsec/Char/LexerSpec.hs 
@@ -1,543 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf       #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE TypeFamilies     #-}--module Text.Megaparsec.Char.LexerSpec (spec) where--import Control.Monad-import Data.Char hiding (ord)-import Data.List (isInfixOf)-import Data.Maybe-import Data.Monoid ((<>))-import Data.Scientific (Scientific, fromFloatDigits)-import Data.Void (Void)-import Numeric (showInt, showHex, showOct, showFFloatAlt)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char.Lexer-import qualified Text.Megaparsec.Char as C--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif--spec :: Spec-spec = do--  describe "space" $-    it "consumes any sort of white space" $-      property $ forAll mkWhiteSpace $ \s -> do-        prs  scn s `shouldParse` ()-        prs' scn s `succeedsLeaving` ""--  describe "symbol" $-    context "when stream begins with the symbol" $-      it "parses the symbol and trailing whitespace" $-        property $ forAll mkSymbol $ \s -> do-          let p = symbol scn y-              y = takeWhile (not . isSpace) s-          prs  p s `shouldParse` y-          prs' p s `succeedsLeaving` ""--  describe "symbol'" $-    context "when stream begins with the symbol" $-      it "parses the symbol and trailing whitespace" $-        property $ forAll mkSymbol $ \s -> do-          let p = symbol' scn y'-              y' = toUpper <$> y-              y = takeWhile (not . isSpace) s-          -- NOTE In some rare cases it's possible that y' will have a-          -- different length than y due to the craziness of Unicode. We-          -- cannot deal with those cases due to how the tokens primitive is-          -- implemented. This is a “feature”, not a bug.-          when (length y' /= length y) discard-          prs  p s `shouldParse` y-          prs' p s `succeedsLeaving` ""--  describe "skipLineComment" $ do-    context "when there is no newline at the end of line" $-      it "is picked up successfully" $ do-        let p = skipLineComment "//"-            s = "// this line comment doesn't have a newline at the end "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""-    it "inner characters are labelled properly" $ do-      let p = skipLineComment "//" <* empty-          s = "// here we go"-      prs  p s `shouldFailWith` err (posN (length s) s) (elabel "character")-      prs' p s `failsLeaving` ""--  describe "skipBlockComment" $-    it "skips a simple block comment" $ do-      let p = skipBlockComment "/*" "*/"-          s = "/* here we go */foo!"-      prs  p s `shouldParse` ()-      prs' p s `succeedsLeaving` "foo!"--  describe "skipBlockCommentNested" $-    context "when it runs into nested block comments" $-      it "parses them all right" $ do-        let p = space (void C.spaceChar) empty-              (skipBlockCommentNested "/*" "*/") <* eof-            s = " /* foo bar /* baz */ quux */ "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""--  describe "indentLevel" $-    it "returns current indentation level (column)" $-      property $ \pos -> do-        let p = setPosition pos *> indentLevel-        prs p "" `shouldParse` sourceColumn pos--  describe "incorrectIndent" $-    it "signals correct parse error" $-      property $ \ord ref actual -> do-        let p :: Parser ()-            p = incorrectIndent ord ref actual-        prs p "" `shouldFailWith` errFancy posI (ii ord ref actual)--  describe "indentGuard" $-    it "works as intended" $-      property $ \n -> do-        let mki = mkIndent sbla (getSmall $ getNonNegative n)-        forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do-          let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-              fragments = [l0,l1,l2]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              p  = ip GT pos1 >>=-                \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn-              ip = indentGuard scn-              sp = void (symbol sc sbla <* C.eol)-          if | col0 <= pos1 ->-               prs p s `shouldFailWith` errFancy posI (ii GT pos1 col0)-             | col1 /= col0 ->-               prs p s `shouldFailWith` errFancy (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)-             | col2 <= col0 ->-               prs p s `shouldFailWith` errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2)-             | otherwise    ->-               prs p s `shouldParse` ()--  describe "nonIdented" $-    it "works as intended" $-      property $ forAll (mkIndent sbla 0) $ \s -> do-        let p = nonIndented scn (symbol scn sbla)-            i = getIndent s-        if i == 0-          then prs p s `shouldParse` sbla-          else prs p s `shouldFailWith` errFancy (posN i s) (ii EQ pos1 (getCol s))--  describe "indentBlock" $ do-    it "works as indented" $-      property $ \mn'' -> do-        let mkBlock = do-              l0 <- mkIndent sbla 0-              l1 <- mkIndent sblb ib-              l2 <- mkIndent sblc (ib + 2)-              l3 <- mkIndent sblb ib-              l4 <- mkIndent' sblc (ib + 2)-              return (l0,l1,l2,l3,l4)-            ib  = fromMaybe 2 mn'-            mn' = getSmall . getPositive <$> mn''-            mn  = mkPos . fromIntegral <$> mn'-        forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do-          let (col0, col1, col2, col3, col4) =-                (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)-              fragments = [l0,l1,l2,l3,l4]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              p = lvla <* eof-              lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla-              lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb-              lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc-              b    = symbol sc-              l x  = return . (x,)-              ib'  = mkPos (fromIntegral ib)-          if | col1 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof)-             | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)-             | col2 <= col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l2 + g 2) s) (ii GT col1 col2)-             | col3 == col2 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utoks sblb <> etoks sblc <> eeof)-             | col3 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof)-             | col3 < col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)-             | col3 > col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)-             | col4 <= col3 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l4 + g 4) s) (ii GT col3 col4)-             | otherwise -> prs p s `shouldParse`-               (sbla, [(sblb, [sblc]), (sblb, [sblc])])-    it "IndentMany works as intended (newline at the end)" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do-        let p    = lvla-            lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  p s `shouldParse` (sbla, [])-        prs' p s `succeedsLeaving` ""-    it "IndentMany works as intended (eof)" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do-        let p    = lvla-            lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  p s `shouldParse` (sbla, [])-        prs' p s `succeedsLeaving` ""-    it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do-      let p    = lvla-          lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-          lvlb = b sblb-          b    = symbol sc-          l x  = return . (x,)-          s    = "aaa\n bbb\n "-      prs  p s `shouldParse` (sbla, [sblb])-      prs' p s `succeedsLeaving` ""-    it "works with many and both IndentMany and IndentNone" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do-        let p1   = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            p2   = indentBlock scn $ IndentNone sbla <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  (many p1) s `shouldParse` [(sbla, [])]-        prs  (many p2) s `shouldParse` [sbla]-        prs' (many p1) s `succeedsLeaving` ""-        prs' (many p2) s `succeedsLeaving` ""-    it "IndentSome expects the specified indentation level for first item" $ do-      let s   = "aaa\n  bbb\n"-          p   = indentBlock scn $-            IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla-          lvlb = symbol sc sblb-          l x = return . (x,)-      prs p s `shouldFailWith` errFancy (posN 6 s)-        (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3))--  describe "lineFold" $-    it "works as intended" $-      property $ do-        let mkFold = do-              l0 <- mkInterspace sbla 0-              l1 <- mkInterspace sblb 1-              l2 <- mkInterspace sblc 1-              return (l0,l1,l2)-        forAll mkFold $ \(l0,l1,l2) -> do-          let p = lineFold scn $ \sc' -> do-                a <- symbol sc' sbla-                b <- symbol sc' sblb-                c <- symbol scn sblc-                return (a, b, c)-              getEnd x = last x == '\n'-              fragments = [l0,l1,l2]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-              (end0, end1)       = (getEnd l0, getEnd l1)-          if | end0 && col1 <= col0 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l1 + g 1) s) (ii GT col0 col1)-             | end1 && col2 <= col0 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2)-             | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)--  describe "charLiteral" $ do-    context "when stream begins with a literal character" $-      it "parses it" $-        property $ \ch -> do-          let p = charLiteral-              s = showLitChar ch ""-          prs  p s `shouldParse` ch-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with a literal character" $-      it "signals correct parse error" $ do-        let p = charLiteral-            s = "\\"-        prs  p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character")-        prs' p s `failsLeaving` s-    context "when stream is empty" $-      it "signals correct parse error" $ do-        let p = charLiteral-        prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character")--  describe "decimal" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = decimal :: Parser Integer-              n = getNonNegative n'-              s = showInt n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with decimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = decimal :: Parser Integer-              s = a : as-          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (decimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "integer")--  describe "octal" $ do-    context "when stream begins with octal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = octal :: Parser Integer-              n = getNonNegative n'-              s = showOct n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with octal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isOctDigit a) ==> do-          let p = octal :: Parser Integer-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "octal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (octal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")--  describe "hexadecimal" $ do-    context "when stream begins with hexadecimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = hexadecimal :: Parser Integer-              n = getNonNegative n'-              s = showHex n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with hexadecimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isHexDigit a) ==> do-          let p = hexadecimal :: Parser Integer-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "hexadecimal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (hexadecimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")--  describe "scientific" $ do-    context "when stream begins with a number" $-      it "parses it" $-        property $ \n' -> do-          let p = scientific :: Parser Scientific-              s = either (show . getNonNegative) (show . getNonNegative)-                (n' :: Either (NonNegative Integer) (NonNegative Double))-          prs p s `shouldParse` case n' of-            Left  x -> fromIntegral    (getNonNegative x)-            Right x -> fromFloatDigits (getNonNegative x)-          prs' p s `succeedsLeaving` ""-    context "when fractional part is interrupted" $-      it "signals correct parse error" $-        property $ \(NonNegative n) -> do-          let p = scientific <* empty :: Parser Scientific-              s = showFFloatAlt Nothing (n :: Double) ""-          prs p s `shouldFailWith` err (posN (length s) s)-            (etok 'E' <> etok 'e' <> elabel "digit")-          prs' p s `failsLeaving` ""-    context "when whole part is followed by a dot without valid fractional part" $-      it "parsing of fractional part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = scientific :: Parser Scientific-              s = showInt (n :: Integer) ".err"-          prs  p s `shouldParse` fromIntegral n-          prs' p s `succeedsLeaving` ".err"-    context "when number is followed by something starting with 'e'" $-      it "parsing of exponent part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = scientific :: Parser Scientific-              s = showFFloatAlt Nothing (n :: Double) "err!"-          prs  p s `shouldParse` fromFloatDigits n-          prs' p s `succeedsLeaving` "err!"-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (scientific :: Parser Scientific) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")--  describe "float" $ do-    context "when stream begins with a float" $-      it "parses it" $-        property $ \n' -> do-          let p = float :: Parser Double-              n = getNonNegative n'-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with a float" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = float :: Parser Double-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "digit")-          prs' p s `failsLeaving` s-    context "when stream begins with an integer (decimal)" $-      it "signals correct parse error" $-        property $ \n' -> do-          let p = float :: Parser Double-              n = getNonNegative n'-              s = show (n :: Integer)-          prs  p s `shouldFailWith` err (posN (length s) s)-            (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")-          prs' p s `failsLeaving` ""-    context "when number is followed by something starting with 'e'" $-      it "parsing of exponent part is backtracked correctly" $-        property $ \(NonNegative n) -> do-          let p = float :: Parser Double-              s = showFFloatAlt Nothing (n :: Double) "err!"-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` "err!"-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (float :: Parser Double) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")-    context "when there is float with just exponent" $-      it "parses it all right" $ do-        let p = float :: Parser Double-        prs  p "123e3" `shouldParse` 123e3-        prs' p "123e3" `succeedsLeaving` ""-        prs  p "123e+3" `shouldParse` 123e+3-        prs' p "123e+3" `succeedsLeaving` ""-        prs  p "123e-3" `shouldParse` 123e-3-        prs' p "123e-3" `succeedsLeaving` ""--  describe "signed" $ do-    context "with integer" $-      it "parses signed integers" $-        property $ \n -> do-          let p :: Parser Integer-              p = signed (hidden C.space) decimal-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with float" $-      it "parses signed floats" $-        property $ \n -> do-          let p :: Parser Double-              p = signed (hidden C.space) float-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with scientific" $-      it "parses singed scientific numbers" $-        property $ \n -> do-          let p = signed (hidden C.space) scientific-              s = either show show (n :: Either Integer Double)-          prs p s `shouldParse` case n of-            Left  x -> fromIntegral    x-            Right x -> fromFloatDigits x-    context "when number is prefixed with plus sign" $-      it "parses the number" $-        property $ \n' -> do-          let p :: Parser Integer-              p = signed (hidden C.space) decimal-              n = getNonNegative n'-              s = '+' : show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when number is prefixed with white space" $-      it "signals correct parse error" $-        property $ \n -> do-          let p :: Parser Integer-              p = signed (hidden C.space) decimal-              s = ' ' : show (n :: Integer)-          prs  p s `shouldFailWith` err posI-            (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")-          prs' p s `failsLeaving` s-    context "when there is white space between sign and digits" $-      it "parses it all right" $ do-        let p :: Parser Integer-            p = signed (hidden C.space) decimal-            s = "- 123"-        prs  p s `shouldParse` (-123)-        prs' p s `succeedsLeaving` ""--------------------------------------------------------------------------------- Helpers--mkWhiteSpace :: Gen String-mkWhiteSpace = concat <$> listOf whiteUnit-  where-    whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]--mkWhiteSpaceNl :: Gen String-mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n"--mkSymbol :: Gen String-mkSymbol = (++) <$> symbolName <*> whiteChars--mkInterspace :: String -> Int -> Gen String-mkInterspace x n = oneof [si, mkIndent x n]-  where-    si = (++ x) <$> listOf (elements " \t")--mkIndent :: String -> Int -> Gen String-mkIndent x n = (++) <$> mkIndent' x n <*> eol-  where-    eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]--mkIndent' :: String -> Int -> Gen String-mkIndent' x n = concat <$> sequence [spc, sym, tra]-  where-    spc = frequency [(5, vectorOf n itm), (1, listOf itm)]-    tra = listOf itm-    itm = elements " \t"-    sym = return x--whiteChars :: Gen String-whiteChars = listOf (elements "\t\n ")--whiteLine :: Gen String-whiteLine = commentOut <$> arbitrary `suchThat` goodEnough-  where-    commentOut x = "//" ++ x ++ "\n"-    goodEnough x = '\n' `notElem` x--whiteBlock :: Gen String-whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough-  where-    commentOut x = "/*" ++ x ++ "*/"-    goodEnough x = not $ "*/" `isInfixOf` x--symbolName :: Gen String-symbolName = listOf $ arbitrary `suchThat` isAlphaNum--sc :: Parser ()-sc = space (void $ takeWhile1P Nothing f) empty empty-  where-    f x = x == ' ' || x == '\t'--scn :: Parser ()-scn = space C.space1 l b-  where-    l = skipLineComment "//"-    b = skipBlockComment "/*" "*/"--getIndent :: String -> Int-getIndent = length . takeWhile isSpace--getCol :: String -> Pos-getCol x = sourceColumn .-  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x--sbla, sblb, sblc :: String-sbla = "aaa"-sblb = "bbb"-sblc = "ccc"--ii :: Ordering -> Pos -> Pos -> EF Void-ii ord ref actual = fancy (ErrorIndentation ord ref actual)
− tests/Text/Megaparsec/CharSpec.hs 
@@ -1,403 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.Megaparsec.CharSpec (spec) where--import Control.Monad-import Data.Char-import Data.List (partition, isPrefixOf)-import Data.Monoid ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--instance Arbitrary GeneralCategory where-  arbitrary = elements [minBound..maxBound]--spec :: Spec-spec = do--  describe "newline" $-    checkStrLit "newline" "\n" (pure <$> newline)--  describe "csrf" $-    checkStrLit "crlf newline" "\r\n" crlf--  describe "eol" $ do-    context "when stream begins with a newline" $-      it "succeeds returning the newline" $-        property $ \s -> do-          let s' = '\n' : s-          prs  eol s' `shouldParse`     "\n"-          prs' eol s' `succeedsLeaving` s-    context "when stream begins with CRLF sequence" $-      it "parses the CRLF sequence" $-        property $ \s -> do-          let s' = '\r' : '\n' : s-          prs  eol s' `shouldParse`     "\r\n"-          prs' eol s' `succeedsLeaving` s-    context "when stream begins with '\\r', but it's not followed by '\\n'" $-      it "signals correct parse error" $-        property $ \ch -> ch /= '\n' ==> do-          let s = ['\r',ch]-          prs eol s `shouldFailWith` err posI (utoks s <> elabel "end of line")-    context "when input stream is '\\r'" $-      it "signals correct parse error" $-        prs eol "\r" `shouldFailWith` err posI-          (utok '\r' <> elabel "end of line")-    context "when stream does not begin with newline or CRLF sequence" $-      it "signals correct parse error" $-        property $ \ch s -> (ch `notElem` "\r\n") ==> do-          let s' = ch : s-          prs eol s' `shouldFailWith` err posI-            (utoks (take 2 s') <> elabel "end of line")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs eol "" `shouldFailWith` err posI-          (ueof <> elabel "end of line")--  describe "tab" $-    checkStrLit "tab" "\t" (pure <$> tab)--  describe "space" $-    it "consumes space up to first non-space character" $-      property $ \s' -> do-        let (s0,s1) = partition isSpace s'-            s = s0 ++ s1-        prs  space s `shouldParse` ()-        prs' space s `succeedsLeaving` s1--  describe "space1" $ do-    context "when stream does not start with a space character" $-      it "signals correct parse error" $-        property $ \ch s' -> not (isSpace ch) ==> do-          let (s0,s1) = partition isSpace s'-              s = ch : s0 ++ s1-          prs  space1 s `shouldFailWith` err posI (utok ch <> elabel "white space")-          prs' space1 s `failsLeaving` s-    context "when stream starts with a space character" $-      it "consumes space up to first non-space character" $-        property $ \s' -> do-          let (s0,s1) = partition isSpace s'-              s = ' ' : s0 ++ s1-          prs  space1 s `shouldParse` ()-          prs' space1 s `succeedsLeaving` s1-    context "when stream is empty" $-      it "signals correct parse error" $-        prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space")--  describe "controlChar" $-    checkCharPred "control character" isControl controlChar--  describe "spaceChar" $-    checkCharRange "white space" " \160\t\n\r\f\v" spaceChar--  describe "upperChar" $-    checkCharPred "uppercase letter" isUpper upperChar--  describe "lowerChar" $-    checkCharPred "lowercase letter" isLower lowerChar--  describe "letterChar" $-    checkCharPred "letter" isAlpha letterChar--  describe "alphaNumChar" $-    checkCharPred "alphanumeric character" isAlphaNum alphaNumChar--  describe "printChar" $-    checkCharPred "printable character" isPrint printChar--  describe "digitChar" $-    checkCharRange "digit" ['0'..'9'] digitChar--  describe "octDigitChar" $-    checkCharRange "octal digit" ['0'..'7'] octDigitChar--  describe "hexDigitChar" $-    checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar--  describe "markChar" $-#if MIN_VERSION_base(4,9,0)-    checkCharRange "mark character" "\71229\7398" markChar-#else-    checkCharRange "mark character" "" markChar-#endif--  describe "numberChar" $-    let xs = "\185\178\179\188\189\190" ++ ['0'..'9']-    in checkCharRange "numeric character" xs numberChar--  describe "punctuationChar" $-    checkCharPred "punctuation" isPunctuation punctuationChar--  describe "symbolChar" $-#if MIN_VERSION_base(4,8,0)-    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar-#else-    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar-#endif-  describe "separatorChar" $-    checkCharRange "separator" " \160" separatorChar--  describe "asciiChar" $-    checkCharPred "ASCII character" isAscii asciiChar--  describe "latin1Char" $ do-    context "when stream begins with Latin-1 character" $-      it "parses the Latin-1 character" $-        property $ \ch s -> isLatin1 ch ==> do-          let s' = ch : s-          prs  latin1Char s' `shouldParse`     ch-          prs' latin1Char s' `succeedsLeaving` s-    context "when stream does not begin with Latin-1 character" $-      it "signals correct parse error" $ do-        prs  latin1Char "б" `shouldFailWith`-          err posI (utok 'б' <> elabel "Latin-1 character")-        prs' latin1Char "в" `failsLeaving`   "в"-    context "when stream is empty" $-      it "signals correct parse error" $-        prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character")--  describe "charCategory" $ do-    context "when parser corresponding to general category of next char is used" $-      it "succeeds" $-        property $ \ch s -> do-          let s' = ch : s-              g  = generalCategory ch-          prs  (charCategory g) s' `shouldParse`     ch-          prs' (charCategory g) s' `succeedsLeaving` s-    context "when parser's category does not match next character's category" $-      it "fails" $-        property $ \g ch s -> (generalCategory ch /= g) ==> do-          let s' = ch : s-          prs  (charCategory g) s' `shouldFailWith`-            err posI (utok ch <> elabel (categoryName g))-          prs' (charCategory g) s' `failsLeaving` s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \g ->-          prs (charCategory g) "" `shouldFailWith`-            err posI (ueof <> elabel (categoryName g))--  describe "char" $ do-    context "when stream begins with the character specified as argument" $-      it "parses the character" $-        property $ \ch s -> do-          let s' = ch : s-          prs  (char ch) s' `shouldParse` ch-          prs' (char ch) s' `succeedsLeaving` s-    context "when stream does not begin with the character specified as argument" $-      it "signals correct parse error" $-        property $ \ch ch' s -> ch /= ch' ==> do-          let s' = ch' : s-          prs  (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch)-          prs' (char ch) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \ch ->-          prs  (char ch) "" `shouldFailWith` err posI (ueof <> etok ch)--  describe "char'" $ do-    let goodChar x =-          (toUpper x == toLower x) || (isUpper x || isLower x)-    context "when stream begins with the character specified as argument" $-      it "parses the character" $-        property $ \ch s -> goodChar ch ==> do-          let sl = toLower ch : s-              su = toUpper ch : s-          prs  (char' ch) sl `shouldParse`     toLower ch-          prs  (char' ch) su `shouldParse`     toUpper ch-          prs' (char' ch) sl `succeedsLeaving` s-          prs' (char' ch) su `succeedsLeaving` s-    context "when stream does not begin with the character specified as argument" $-      it "signals correct parse error" $-        property $ \ch ch' s -> goodChar ch && toLower ch /= toLower ch' ==> do-          let s' = ch' : s-              ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch)-          prs  (char' ch) s' `shouldFailWith` err posI ms-          prs' (char' ch) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \ch -> goodChar ch ==> do-          let ms = ueof <> etok (toLower ch) <> etok (toUpper ch)-          prs  (char' ch) "" `shouldFailWith` err posI ms--  describe "anyChar" $ do-    context "when stream is not empty" $-      it "succeeds consuming next character in the stream" $-        property $ \ch s -> do-          let s' = ch : s-          prs  anyChar s' `shouldParse`     ch-          prs' anyChar s' `succeedsLeaving` s-    context "when stream is empty" $-      it "signals correct parse error" $-        prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character")--  describe "notChar" $ do-    context "when stream begins with the character specified as argument" $-      it "signals correct parse error" $-        property $ \ch s' -> do-          let p = notChar ch-              s = ch : s'-          prs p s `shouldFailWith` err posI (utok ch)-          prs' p s `failsLeaving` s-    context "when stream does not begin with the character specified as argument" $-      it "parses first character in the stream" $-        property $ \ch s -> not (null s) && ch /= head s ==> do-          let p = notChar ch-          prs  p s `shouldParse` head s-          prs' p s `succeedsLeaving` tail s-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (notChar 'a') "" `shouldFailWith` err posI ueof--  describe "oneOf" $ do-    context "when stream begins with one of specified characters" $-      it "parses the character" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              s'  = ch : s-          prs  (oneOf chs) s' `shouldParse`     ch-          prs' (oneOf chs) s' `succeedsLeaving` s-    context "when stream does not begin with any of specified characters" $-      it "signals correct parse error" $-        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do-          let s' = ch : s-          prs  (oneOf chs) s' `shouldFailWith` err posI (utok ch)-          prs' (oneOf chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof--  describe "noneOf" $ do-    context "when stream does not begin with any of specified characters" $-      it "parses the character" $-        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do-          let s' = ch : s-          prs  (noneOf chs) s' `shouldParse`     ch-          prs' (noneOf chs) s' `succeedsLeaving` s-    context "when stream begins with one of specified characters" $-      it "signals correct parse error" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              s'  = ch : s-          prs  (noneOf chs) s' `shouldFailWith` err posI (utok ch)-          prs' (noneOf chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof--  describe "string" $ do-    context "when stream is prefixed with given string" $-      it "parses the string" $-        property $ \str s -> do-          let s' = str ++ s-          prs  (string str) s' `shouldParse`     str-          prs' (string str) s' `succeedsLeaving` s-    context "when stream is not prefixed with given string" $-      it "signals correct parse error" $-        property $ \str s -> not (str `isPrefixOf` s) ==> do-          let us = take (length str) s-          prs (string str) s `shouldFailWith`-            err posI (utoks us <> etoks str)--  describe "string'" $ do-    context "when stream is prefixed with given string" $-      it "parses the string" $-        property $ \str s ->-          forAll (fuzzyCase str) $ \str' -> do-            let s' = str' ++ s-            prs  (string' str) s' `shouldParse`     str'-            prs' (string' str) s' `succeedsLeaving` s-    context "when stream is not prefixed with given string" $-      it "signals correct parse error" $-        property $ \str s -> not (str `isPrefixOfI` s) ==> do-          let us = take (length str) s-          prs  (string' str) s `shouldFailWith`-            err posI (utoks us <> etoks str)--------------------------------------------------------------------------------- Helpers--checkStrLit :: String -> String -> Parser String -> SpecWith ()-checkStrLit name ts p = do-  context ("when stream begins with " ++ name) $-    it ("parses the " ++ name) $-      property $ \s -> do-        let s' = ts ++ s-        prs  p s' `shouldParse`     ts-        prs' p s' `succeedsLeaving` s-  context ("when stream does not begin with " ++ name) $-    it "signals correct parse error" $-      property $ \ch s -> ch /= head ts ==> do-       let s' = ch : s-           us = take (length ts) s'-       prs  p s' `shouldFailWith` err posI (utoks us <> etoks ts)-       prs' p s' `failsLeaving`   s'-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> etoks ts)--checkCharPred :: String -> (Char -> Bool) -> Parser Char -> SpecWith ()-checkCharPred name f p = do-  context ("when stream begins with " ++ name) $-    it ("parses the " ++ name) $-      property $ \ch s -> f ch ==> do-        let s' = ch : s-        prs  p s' `shouldParse`     ch-        prs' p s' `succeedsLeaving` s-  context ("when stream does not begin with " ++ name) $-    it "signals correct parse error" $-      property $ \ch s -> not (f ch) ==> do-       let s' = ch : s-       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)-       prs' p s' `failsLeaving`   s'-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)--checkCharRange :: String -> String -> Parser Char -> SpecWith ()-checkCharRange name tchs p = do-  forM_ tchs $ \tch ->-    context ("when stream begins with " ++ showTokens (nes tch)) $-      it ("parses the " ++ showTokens (nes tch)) $-        property $ \s -> do-          let s' = tch : s-          prs  p s' `shouldParse`     tch-          prs' p s' `succeedsLeaving` s-  context "when stream is empty" $-    it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)---- | Randomly change the case in the given string.--fuzzyCase :: String -> Gen String-fuzzyCase s = zipWith f s <$> vector (length s)-  where-    f k True  = if isLower k then toUpper k else toLower k-    f k False = k---- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toUpper x == toUpper y---- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff--- the first list is a prefix of the second with case-insensitive--- comparison.--isPrefixOfI :: String -> String -> Bool-isPrefixOfI [] _  =  True-isPrefixOfI _  [] =  False-isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys
− tests/Text/Megaparsec/ErrorSpec.hs 
@@ -1,311 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.ErrorSpec (spec) where--import Data.ByteString (ByteString)-import Data.Char (isControl, isSpace)-import Data.List (isInfixOf, isSuffixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Void-import Data.Word (Word8)-import Test.Hspec-import Test.Hspec.Megaparsec.AdHoc ()-import Test.QuickCheck-import Text.Megaparsec.Error-import Text.Megaparsec.Error.Builder-import Text.Megaparsec.Pos-import qualified Data.ByteString    as B-import qualified Data.List.NonEmpty as NE-import qualified Data.Semigroup     as S-import qualified Data.Set           as E--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable, all)-import Prelude hiding (all)-#else-import Control.Exception (Exception (..))-#endif-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#endif--type PE = ParseError Char Void-type PW = ParseError Word8 Void--spec :: Spec-spec = do--  describe "Semigroup instance of ParseError" $-    it "associativity" $-      property $ \x y z ->-        (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE)--  describe "Monoid instance of ParseError" $ do-    it "left identity" $-      property $ \x ->-        mempty <> x === (x :: PE)-    it "right identity" $-      property $ \x ->-        x <> mempty === (x :: PE)-    it "associativity" $-      property $ \x y z ->-        (x <> y) <> z === (x <> (y <> z) :: PE)--  describe "Read and Show instances of ParseError" $-    it "printed representation of ParseError can be read back" $-      property $ \x ->-        read (show x) === (x :: PE)--  describe "error merging with (<>)" $ do-    it "selects greater source position" $-      property $ \x y ->-        errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)-    context "when combining two trivial parse errors at the same position" $-      it "merges their unexpected and expected items" $ do-        let 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)-        property $ \pos us0 ps0 us1 ps1 ->-          TrivialError pos us0 ps0 <> TrivialError pos us1 ps1 `shouldBe`-            (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE)-    context "when combining two fancy parse errors at the same position" $-      it "merges their custom items" $-        property $ \pos xs0 xs1 ->-          FancyError pos xs0 <> FancyError pos xs1 `shouldBe`-            (FancyError pos (E.union xs0 xs1) :: PE)-    context "when combining trivial error with fancy error" $ do-      it "fancy has precedence (left)" $-        property $ \pos us ps xs ->-          FancyError pos xs <> TrivialError pos us ps `shouldBe`-            (FancyError pos xs :: PE)-      it "fancy has precedence (right)" $-        property $ \pos us ps xs ->-          TrivialError pos us ps <> FancyError pos xs `shouldBe`-            (FancyError pos xs :: PE)--  describe "errorPos" $-    it "returns error position" $-      property $ \e ->-        errorPos e `shouldBe`-          (case e :: PE of-            TrivialError pos _ _ -> pos-            FancyError   pos _   -> pos)--  describe "showTokens (Char instance)" $ do-    let f :: String -> String -> Expectation-        f x y = showTokens (NE.fromList x) `shouldBe` y-    it "shows CRLF newline correctly"-      (f "\r\n" "crlf newline")-    it "shows null byte correctly"-      (f "\NUL" "null")-    it "shows start of heading correctly"-      (f "\SOH" "start of heading")-    it "shows start of text correctly"-      (f "\STX" "start of text")-    it "shows end of text correctly"-      (f "\ETX" "end of text")-    it "shows end of transmission correctly"-      (f "\EOT" "end of transmission")-    it "shows enquiry correctly"-      (f "\ENQ" "enquiry")-    it "shows acknowledge correctly"-      (f "\ACK" "acknowledge")-    it "shows bell correctly"-      (f "\BEL" "bell")-    it "shows backspace correctly"-      (f "\BS" "backspace")-    it "shows tab correctly"-      (f "\t" "tab")-    it "shows newline correctly"-      (f "\n" "newline")-    it "shows vertical tab correctly"-      (f "\v" "vertical tab")-    it "shows form feed correctly"-      (f "\f" "form feed")-    it "shows carriage return correctly"-      (f "\r" "carriage return")-    it "shows shift out correctly"-      (f "\SO" "shift out")-    it "shows shift in correctly"-      (f "\SI" "shift in")-    it "shows data link escape correctly"-      (f "\DLE" "data link escape")-    it "shows device control one correctly"-      (f "\DC1" "device control one")-    it "shows device control two correctly"-      (f "\DC2" "device control two")-    it "shows device control three correctly"-      (f "\DC3" "device control three")-    it "shows device control four correctly"-      (f "\DC4" "device control four")-    it "shows negative acknowledge correctly"-      (f "\NAK" "negative acknowledge")-    it "shows synchronous idle correctly"-      (f "\SYN" "synchronous idle")-    it "shows end of transmission block correctly"-      (f "\ETB" "end of transmission block")-    it "shows cancel correctly"-      (f "\CAN" "cancel")-    it "shows end of medium correctly"-      (f "\EM"  "end of medium")-    it "shows substitute correctly"-      (f "\SUB" "substitute")-    it "shows escape correctly"-      (f "\ESC" "escape")-    it "shows file separator correctly"-      (f "\FS"  "file separator")-    it "shows group separator correctly"-      (f "\GS"  "group separator")-    it "shows record separator correctly"-      (f "\RS"  "record separator")-    it "shows unit separator correctly"-      (f "\US"  "unit separator")-    it "shows delete correctly"-      (f "\DEL" "delete")-    it "shows space correctly"-      (f " "    "space")-    it "shows non-breaking space correctly"-      (f "\160" "non-breaking space")-    it "shows other single characters in single quotes" $-      property $ \ch ->-        not (isControl ch) && not (isSpace ch) ==>-          showTokens (ch :| []) === "\'" <> [ch] <> "\'"-    it "shows strings in double quotes" $-      property $ \str' ->-        let str = filter (not . g) str'-            g x = isControl x || x `elem` ['\160']-        in length str > 1 ==>-             showTokens (NE.fromList str) === ("\"" <> str <> "\"")-    it "shows control characters in long strings property"-      (f "{\n" "\"{<newline>\"")--  describe "showTokens (Word8 instance)" $-    it "basically works" $ do-      -- NOTE Currently the Word8 instance is defined via Char intance, so-      -- the testing is rather shallow.-      let ts = NE.fromList [10,48,49,50] :: NonEmpty Word8-      showTokens ts `shouldBe` "\"<newline>012\""--  describe "parseErrorPretty" $ do-    it "shows unknown ParseError correctly" $-      parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"-    it "result always ends with a newline" $-      property $ \x ->-        parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)-    it "result contains representation of source pos stack" $-      property (contains errorPos sourcePosPretty)-    it "result contains representation of unexpected items" $ do-      let f (TrivialError _ us _) = us-          f _                     = Nothing-      property (contains f showErrorComponent)-    it "result contains representation of expected items" $ do-      let f (TrivialError _ _ ps) = ps-          f _                     = E.empty-      property (contains f showErrorComponent)-    it "result contains representation of custom items" $ do-      let f (FancyError _ xs) = xs-          f _                 = E.empty-      property (contains f showErrorComponent)-    it "several fancy errors look not so bad" $ do-      let pe :: PE-          pe = errFancy posI $-            mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")-      parseErrorPretty pe `shouldBe` "1:1:\nbar\nfoo\n"--  describe "parseErrorPretty'" $ do-    context "with Char tokens" $ do-      it "shows empty line correctly" $ do-        let s = "" :: String-        parseErrorPretty' s (mempty :: PE) `shouldBe`-          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"-      it "shows position on first line correctly" $ do-        let s = "abc" :: String-            pe = err (posN 1 s) (utok 'b' <> etok 'd') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"-      it "skips to second line correctly" $ do-        let s = "one\ntwo\n" :: String-            pe = err (posN 4 s) (utok 't' <> etok 'x') :: PE-        parseErrorPretty' s pe `shouldBe`-          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"-      it "shows position on 1000 line correctly" $ do-        let s = replicate 999 '\n' ++ "abc"-            pe = err (posN 999 s) (utok 'a' <> etok 'd') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"-      it "shows offending line in the presence of tabs correctly" $ do-        let s = "\tsomething" :: String-            pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"-    context "with Word8 tokens" $ do-      it "shows empty line correctly" $ do-        let s = "" :: ByteString-        parseErrorPretty' s (mempty :: PW) `shouldBe`-          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"-      it "shows position on first line correctly" $ do-        let s = "abc" :: ByteString-            pe = err (posN 1 s) (utok 98 <> etok 100) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"-      it "skips to second line correctly" $ do-        let s = "one\ntwo\n" :: ByteString-            pe = err (posN 4 s) (utok 116 <> etok 120) :: PW-        parseErrorPretty' s pe `shouldBe`-          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"-      it "shows position on 1000 line correctly" $ do-        let s = B.replicate 999 10 <> "abc"-            pe = err (posN 999 s) (utok 97 <> etok 100) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"-      it "shows offending line in the presence of tabs correctly" $ do-        let s = "\tsomething" :: ByteString-            pe = err (posN 1 s) (utok 115 <> etok 120) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"--  describe "parseErrorPretty_" $-    it "takes tab width into account correctly" $-      property $ \w' -> do-        let s  = "\tsomething\t" :: String-            pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE-            w  = unPos w'-        parseErrorPretty_ w' s pe `shouldBe`-          ("1:9:\n  |\n1 | " ++ replicate w ' ' ++ "something" ++ replicate w ' '-           ++ "\n  |         ^\nunexpected 's'\nexpecting 'x'\n")--  describe "sourcePosStackPretty" $-    it "result never ends with a newline " $-      property $ \x ->-        let pos = errorPos (x :: PE)-        in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)--  describe "parseErrorTextPretty" $ do-    it "shows trivial unknown ParseError correctly" $-      parseErrorTextPretty (mempty :: PE)-        `shouldBe` "unknown parse error\n"-    it "shows fancy unknown ParseError correctly" $-      parseErrorTextPretty (FancyError posI E.empty :: PE)-        `shouldBe` "unknown fancy parse error\n"-    it "result always ends with a newline" $-      property $ \x ->-        parseErrorTextPretty (x :: PE)-          `shouldSatisfy` ("\n" `isSuffixOf`)--#if MIN_VERSION_base(4,8,0)-  describe "displayException" $-    it "produces the same result as parseErrorPretty" $-      property $ \x ->-        displayException x `shouldBe` parseErrorPretty (x :: PE)-#endif--------------------------------------------------------------------------------- Helpers--contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property-contains g r e = property (all f (g e))-  where-    rendered = parseErrorPretty e-    f x = r x `isInfixOf` rendered
− tests/Text/Megaparsec/ExprSpec.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}--module Text.Megaparsec.ExprSpec (spec) where--import Data.Monoid ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char-import Text.Megaparsec.Expr--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif--spec :: Spec-spec =-  describe "makeExprParser" $ do-    context "when given valid rendered AST" $-      it "can parse it back" $-        property $ \node -> do-          let s = showNode node-          prs  expr s `shouldParse`     node-          prs' expr s `succeedsLeaving` ""-    context "when stream in empty" $-      it "signals correct parse error" $-        prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term")-    context "when term is missing" $-      it "signals correct parse error" $ do-        let p = expr <* eof-        prs p "-" `shouldFailWith` err (posN 1 "-") (ueof <> elabel "term")-        prs p "(" `shouldFailWith` err (posN 1 "(") (ueof <> elabel "term")-        prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term")-    context "operator is missing" $-      it "signals correct parse error" $-        property $ \a b -> do-          let p = expr <* eof-              a' = inParens a-              n  = length a' + 1-              s  = a'  ++ " " ++ inParens b-              c  = s !! n-          if c == '-'-            then prs p s `shouldParse` Sub a b-            else prs p s `shouldFailWith`-                 err (posN n s) (utok c <> eeof <> elabel "operator")---- Algebraic structures to build abstract syntax tree of our expression.--data Node-  = Val Integer   -- ^ literal value-  | Neg Node      -- ^ negation (prefix unary)-  | Fac Node      -- ^ factorial (postfix unary)-  | Mod Node Node -- ^ modulo-  | Sum Node Node -- ^ summation (addition)-  | Sub Node Node -- ^ subtraction-  | Pro Node Node -- ^ product-  | Div Node Node -- ^ division-  | Exp Node Node -- ^ exponentiation-    deriving (Eq, Show)--instance Enum Node where-  fromEnum (Val _)   = 0-  fromEnum (Neg _)   = 0-  fromEnum (Fac _)   = 0-  fromEnum (Mod _ _) = 0-  fromEnum (Exp _ _) = 1-  fromEnum (Pro _ _) = 2-  fromEnum (Div _ _) = 2-  fromEnum (Sum _ _) = 3-  fromEnum (Sub _ _) = 3-  toEnum   _         = error "Oops!"--instance Ord Node where-  x `compare` y = fromEnum x `compare` fromEnum y--showNode :: Node -> String-showNode (Val x)     = show x-showNode n@(Neg x)   = "-" ++ showGT n x-showNode n@(Fac x)   = showGT n x ++ "!"-showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y-showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y-showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y-showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y-showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y-showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y--showGT :: Node -> Node -> String-showGT parent node = (if node > parent then showCmp else showNode) node--showGE :: Node -> Node -> String-showGE parent node = (if node >= parent then showCmp else showNode) node--showCmp :: Node -> String-showCmp node = (if fromEnum node == 0 then showNode else inParens) node--inParens :: Node -> String-inParens x = "(" ++ showNode x ++ ")"--instance Arbitrary Node where-  arbitrary = sized arbitraryN0--arbitraryN0 :: Int -> Gen Node-arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)-                          , (9, arbitraryN1 n) ]-  where-    leaf = arbitraryN1 (n `div` 2)--arbitraryN1 :: Int -> Gen Node-arbitraryN1 n =- frequency [ (1, Neg <$> arbitraryN2 n)-           , (1, Fac <$> arbitraryN2 n)-           , (7, arbitraryN2 n)]--arbitraryN2 :: Int -> Gen Node-arbitraryN2 0 = Val . getNonNegative <$> arbitrary-arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf-  where-    leaf = arbitraryN0 (n `div` 2)---- Some helpers are put here since we don't want to depend on--- "Text.Megaparsec.Lexer".--lexeme :: Parser a -> Parser a-lexeme p = p <* hidden space--symbol :: String -> Parser String-symbol = lexeme . string--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--integer :: Parser Integer-integer = lexeme (read <$> some digitChar <?> "integer")---- Here we use a table of operators that makes use of all features of--- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex--- but valid expressions and render them to get their textual--- representation.--expr :: Parser Node-expr = makeExprParser term table--term :: Parser Node-term = parens expr <|> (Val <$> integer) <?> "term"--table :: [[Operator Parser Node]]-table =-  [ [ Prefix  (Neg <$ symbol "-")-    , Postfix (Fac <$ symbol "!")-    , InfixN  (Mod <$ symbol "%") ]-  , [ InfixR  (Exp <$ symbol "^") ]-  , [ InfixL  (Pro <$ symbol "*")-    , InfixL  (Div <$ symbol "/") ]-  , [ InfixL  (Sum <$ symbol "+")-    , InfixL  (Sub <$ symbol "-")] ]
− tests/Text/Megaparsec/PermSpec.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE MultiWayIf #-}--module Text.Megaparsec.PermSpec (spec) where--import Control.Applicative-import Data.List (nub, elemIndices)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char-import Text.Megaparsec.Char.Lexer (decimal)-import Text.Megaparsec.Perm--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#endif--data CharRows = CharRows-  { getChars :: (Char, Char, Char)-  , getInput :: String }-  deriving (Eq, Show)--instance Arbitrary CharRows where-  arbitrary = do-    chars@(a,b,c) <- arbitrary `suchThat` different-    an            <- arbitrary-    bn            <- arbitrary-    cn            <- arbitrary-    input <- concat <$> shuffle-             [ replicate an a-             , replicate bn b-             , replicate cn c]-    return $ CharRows chars input-      where different (a,b,c) = let l = [a,b,c] in l == nub l--spec :: Spec-spec = do--  describe "(<$$>)" $ do-    context "when supplied parser succeeds" $-      it "returns value returned by the parser" $-        property $ \n -> do-          let p = makePermParser (succ <$$> pure (n :: Integer))-          prs p "" `shouldParse` succ n-    context "when supplied parser fails" $-      it "signals correct parse error" $ do-          let p = makePermParser (succ <$$> decimal) :: Parser Integer-          prs p "" `shouldFailWith` err posI (ueof <> elabel "integer")--  describe "(<$?>)" $ do-    context "when supplied parser succeeds" $-      it "returns value returned by the parser" $-        property $ \n m -> do-          let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer)))-          prs p "" `shouldParse` succ m-    context "when supplied parser fails" $-      it "returns the default value" $-        property $ \n -> do-          let p = makePermParser (succ <$?> (n :: Integer, fail "foo"))-          prs p "" `shouldParse` succ n-    context "when stream in empty" $-      it "returns the default value" $-        property $ \n -> do-          let p = makePermParser (succ <$?> (n :: Integer, decimal))-          prs p "" `shouldParse` succ n--  describe "makeExprParser" $-    it "works" $-      property $ \a' c' v -> do-        let (a,b,c) = getChars v-            p = makePermParser-              ((,,) <$?> (a' :: String, some (char a))-                <||> char b-                <|?> (c', char c))-            bis  = elemIndices b s-            preb = take (bis !! 1) s-            cis  = elemIndices c s-            prec = take (cis !! 1) s-            s    = getInput v-        if | length bis > 1 && (length cis <= 1 || head bis < head cis) ->-               prs_ p s `shouldFailWith` err (posN (bis !! 1) s)-                 ( utok b <> eeof <>-                   (if a `elem` preb then mempty else etok a) <>-                   (if c `elem` preb then mempty else etok c) )-           | length cis > 1 ->-               prs_ p s `shouldFailWith` err (posN (cis !! 1) s)-                 ( utok c <>-                   (if a `elem` prec then mempty else etok a) <>-                   (if b `elem` prec then eeof   else etok b) )-           | b `notElem` s ->-               prs_ p s `shouldFailWith` err (posN (length s) s)-                 ( ueof <> etok b <>-                   (if a `notElem` s || last s == a then etok a else mempty) <>-                   (if c `elem` s then mempty else etok c) )-           | otherwise ->-               prs_ p s `shouldParse`-                 ( if a `elem` s then filter (== a) s else a'-                 , b-                 , if c `elem` s then c else c' )
− tests/Text/Megaparsec/PosSpec.hs 
@@ -1,63 +0,0 @@-module Text.Megaparsec.PosSpec (spec) where--import Control.Exception (evaluate)-import Data.Function (on)-import Data.List (isInfixOf)-import Data.Semigroup ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec.AdHoc ()-import Test.QuickCheck-import Text.Megaparsec.Pos--spec :: Spec-spec = do--  describe "mkPos" $ do-    context "when the argument is a non-positive number" $-      it "throws InvalidPosException" $-        property $ \n -> n <= 0 ==>-          evaluate (mkPos n) `shouldThrow` (== InvalidPosException n)-    context "when the argument is not 0" $-      it "returns Pos with the given value" $-        property $ \n ->-          (n > 0) ==> (unPos (mkPos n) `shouldBe` n)--  describe "Read and Show instances of Pos" $-    it "printed representation of Pos is isomorphic to its value" $-      property $ \x ->-        read (show x) === (x :: Pos)--  describe "Ord instance of Pos" $-    it "works just like Ord instance of underlying Word" $-      property $ \x y ->-        compare x y === (compare `on` unPos) x y--  describe "Semigroup instance of Pos" $-    it "works like addition" $-      property $ \x y ->-        x <> y === mkPos (unPos x + unPos y) .&&.-        unPos (x <> y) === unPos x + unPos y--  describe "initialPos" $-    it "constructs initial position correctly" $-      property $ \path ->-        let x = initialPos path-        in sourceName   x === path    .&&.-           sourceLine   x === mkPos 1 .&&.-           sourceColumn x === mkPos 1--  describe "Read and Show instances of SourcePos" $-    it "printed representation of SourcePos in isomorphic to its value" $-      property $ \x ->-        read (show x) === (x :: SourcePos)--  describe "sourcePosPretty" $ do-    it "displays file name" $-      property $ \x ->-        sourceName x `isInfixOf` sourcePosPretty x-    it "displays line number" $-      property $ \x ->-        (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x-    it "displays column number" $-      property $ \x ->-        (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x
− tests/Text/Megaparsec/StreamSpec.hs 
@@ -1,414 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.StreamSpec (spec) where--import Data.Char (isLetter, chr)-import Data.Proxy-import Data.Semigroup ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text            as T-import qualified Data.Text.Lazy       as TL--spec :: Spec-spec = do--  describe "String instance of Stream" $ do-    describe "tokenToChunk" $-      it "produces the same result as singleton with tokensToChunk" $-        property $ \ch ->-          tokenToChunk sproxy ch === tokensToChunk sproxy [ch]-    describe "tokensToChunk" $-      it "list of tokens is isomorphic to chunk" $-        property $ \ts ->-          chunkToTokens sproxy (tokensToChunk sproxy ts) === ts-    describe "chunkToTokens" $-      it "chunk is isomorphic to list of tokens" $-        property $ \chunk ->-          tokensToChunk sproxy (chunkToTokens sproxy chunk) === chunk-    describe "chunkLength" $-      it "returns correct length of given chunk" $-        property $ \chunk ->-          chunkLength sproxy chunk === length chunk-    describe "chunkEmpty" $-      it "only true when chunkLength returns 0" $-        property $ \chunk ->-          chunkEmpty sproxy chunk === (chunkLength sproxy chunk <= 0)-    describe "positionAt1" $-      it "just returns the given position" $-        property $ \pos t ->-          positionAt1 sproxy pos t === pos-    describe "positionAtN" $-      it "just returns the given position" $-        property $ \pos chunk ->-          positionAtN sproxy pos chunk === pos-    describe "advance1" $ do-      context "when given newline" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l _) ->-            advance1 sproxy w pos '\n' === SourcePos n (l <> pos1) pos1-      context "when given tab" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l c) ->-            advance1 sproxy w pos '\t' === SourcePos n l (toNextTab w c)-      context "when given other character" $-        it "works correctly" $-          property $ \ch w pos@(SourcePos n l c) ->-            (ch /= '\n' && ch /= '\t') ==>-              advance1 sproxy w pos ch === SourcePos n l (c <> pos1)-    describe "advanceN" $-      it "works correctly" $-        advanceN sproxy defaultTabWidth (initialPos "") "something\n\tfoo"-          === SourcePos "" (mkPos 2) (mkPos 12)-    describe "take1_" $ do-      context "when input in empty" $-        it "returns Nothing" $-          take1_ ("" :: String) === Nothing-      context "when input is not empty" $-        it "unconses a token" $-          property $ \s -> not (null s) ==>-            take1_ (s :: String) === Just (head s, tail s)-    describe "takeN_" $ do-      context "requested length is 0" $-        it "returns Just empty chunk and original stream" $-          property $ \s ->-            takeN_ 0 (s :: String) === Just ("", s)-      context "requested length is greater than 0" $ do-        context "stream is empty" $-          it "returns Nothing" $-            property $ \(Positive n) ->-              takeN_ n ("" :: String) === Nothing-        context "stream is not empty" $-          it "returns a chunk of correct length and rest of the stream" $-            property $ \(Positive n) s -> not (null s) ==>-              takeN_ n (s :: String) === Just (splitAt n s)-    describe "takeWhile_" $-      it "extracts a chunk that is a prefix consisting of matching tokens" $-        property $ \s ->-          takeWhile_ isLetter s === span isLetter s--  describe "ByteString instance of Stream" $ do-    describe "tokenToChunk" $-      it "produces the same result as singleton with tokensToChunk" $-        property $ \ch ->-          tokenToChunk bproxy ch === tokensToChunk bproxy [ch]-    describe "tokensToChunk" $-      it "list of tokens is isomorphic to chunk" $-        property $ \ts ->-          chunkToTokens bproxy (tokensToChunk bproxy ts) === ts-    describe "chunkToTokens" $-      it "chunk is isomorphic to list of tokens" $-        property $ \chunk ->-          tokensToChunk bproxy (chunkToTokens bproxy chunk) === chunk-    describe "chunkLength" $-      it "returns correct length of given chunk" $-        property $ \chunk ->-          chunkLength bproxy chunk === B.length chunk-    describe "chunkEmpty" $-      it "only true when chunkLength returns 0" $-        property $ \chunk ->-          chunkEmpty bproxy chunk === (chunkLength bproxy chunk <= 0)-    describe "positionAt1" $-      it "just returns the given position" $-        property $ \pos t ->-          positionAt1 bproxy pos t === pos-    describe "positionAtN" $-      it "just returns the given position" $-        property $ \pos chunk ->-          positionAtN bproxy pos chunk === pos-    describe "advance1" $ do-      context "when given newline" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l _) ->-            advance1 bproxy w pos 10 === SourcePos n (l <> pos1) pos1-      context "when given tab" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l c) ->-            advance1 bproxy w pos 9 === SourcePos n l (toNextTab w c)-      context "when given other character" $-        it "works correctly" $-          property $ \ch w pos@(SourcePos n l c) ->-            (ch /= 10 && ch /= 9) ==>-              advance1 bproxy w pos ch === SourcePos n l (c <> pos1)-    describe "advanceN" $-      it "works correctly" $-        advanceN bproxy defaultTabWidth (initialPos "") "something\n\tfoo"-          === SourcePos "" (mkPos 2) (mkPos 12)-    describe "take1_" $ do-      context "when input in empty" $-        it "returns Nothing" $-          take1_ ("" :: B.ByteString) === Nothing-      context "when input is not empty" $-        it "unconses a token" $-          property $ \s -> not (B.null s) ==>-            take1_ (s :: B.ByteString) === B.uncons s-    describe "takeN_" $ do-      context "requested length is 0" $-        it "returns Just empty chunk and original stream" $-          property $ \s ->-            takeN_ 0 (s :: B.ByteString) === Just ("", s)-      context "requested length is greater than 0" $ do-        context "stream is empty" $-          it "returns Nothing" $-            property $ \(Positive n) ->-              takeN_ n ("" :: B.ByteString) === Nothing-        context "stream is not empty" $-          it "returns a chunk of correct length and rest of the stream" $-            property $ \(Positive n) s -> not (B.null s) ==>-              takeN_ n (s :: B.ByteString) === Just (B.splitAt n s)-    describe "takeWhile_" $-      it "extracts a chunk that is a prefix consisting of matching tokens" $-        property $ \s ->-          let f = isLetter . chr . fromIntegral-          in takeWhile_ f s === B.span f s--  describe "Lazy ByteString instance of Stream" $ do-    describe "tokenToChunk" $-      it "produces the same result as singleton with tokensToChunk" $-        property $ \ch ->-          tokenToChunk blproxy ch === tokensToChunk blproxy [ch]-    describe "tokensToChunk" $-      it "list of tokens is isomorphic to chunk" $-        property $ \ts ->-          chunkToTokens blproxy (tokensToChunk blproxy ts) === ts-    describe "chunkToTokens" $-      it "chunk is isomorphic to list of tokens" $-        property $ \chunk ->-          tokensToChunk blproxy (chunkToTokens blproxy chunk) === chunk-    describe "chunkLength" $-      it "returns correct length of given chunk" $-        property $ \chunk ->-          chunkLength blproxy chunk === fromIntegral (BL.length chunk)-    describe "chunkEmpty" $-      it "only true when chunkLength returns 0" $-        property $ \chunk ->-          chunkEmpty blproxy chunk === (chunkLength blproxy chunk <= 0)-    describe "positionAt1" $-      it "just returns the given position" $-        property $ \pos t ->-          positionAt1 blproxy pos t === pos-    describe "positionAtN" $-      it "just returns the given position" $-        property $ \pos chunk ->-          positionAtN blproxy pos chunk === pos-    describe "advance1" $ do-      context "when given newline" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l _) ->-            advance1 blproxy w pos 10 === SourcePos n (l <> pos1) pos1-      context "when given tab" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l c) ->-            advance1 blproxy w pos 9 === SourcePos n l (toNextTab w c)-      context "when given other character" $-        it "works correctly" $-          property $ \ch w pos@(SourcePos n l c) ->-            (ch /= 10 && ch /= 9) ==>-              advance1 blproxy w pos ch === SourcePos n l (c <> pos1)-    describe "advanceN" $-      it "works correctly" $-        advanceN blproxy defaultTabWidth (initialPos "") "something\n\tfoo"-          === SourcePos "" (mkPos 2) (mkPos 12)-    describe "take1_" $ do-      context "when input in empty" $-        it "returns Nothing" $-          take1_ ("" :: BL.ByteString) === Nothing-      context "when input is not empty" $-        it "unconses a token" $-          property $ \s -> not (BL.null s) ==>-            take1_ (s :: BL.ByteString) === BL.uncons s-    describe "takeN_" $ do-      context "requested length is 0" $-        it "returns Just empty chunk and original stream" $-          property $ \s ->-            takeN_ 0 (s :: BL.ByteString) === Just ("", s)-      context "requested length is greater than 0" $ do-        context "stream is empty" $-          it "returns Nothing" $-            property $ \(Positive n) ->-              takeN_ n ("" :: BL.ByteString) === Nothing-        context "stream is not empty" $-          it "returns a chunk of correct length and rest of the stream" $-            property $ \(Positive n) s -> not (BL.null s) ==>-              takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s)-    describe "takeWhile_" $-      it "extracts a chunk that is a prefix consisting of matching tokens" $-        property $ \s ->-          let f = isLetter . chr . fromIntegral-          in takeWhile_ f s === BL.span f s--  describe "Text instance of Stream" $ do-    describe "tokenToChunk" $-      it "produces the same result as singleton with tokensToChunk" $-        property $ \ch ->-          tokenToChunk tproxy ch === tokensToChunk tproxy [ch]-    describe "tokensToChunk" $-      it "list of tokens is isomorphic to chunk" $-        property $ \ts ->-          chunkToTokens tproxy (tokensToChunk tproxy ts) === ts-    describe "chunkToTokens" $-      it "chunk is isomorphic to list of tokens" $-        property $ \chunk ->-          tokensToChunk tproxy (chunkToTokens tproxy chunk) === chunk-    describe "chunkLength" $-      it "returns correct length of given chunk" $-        property $ \chunk ->-          chunkLength tproxy chunk === T.length chunk-    describe "chunkEmpty" $-      it "only true when chunkLength returns 0" $-        property $ \chunk ->-          chunkEmpty tproxy chunk === (chunkLength tproxy chunk <= 0)-    describe "positionAt1" $-      it "just returns the given position" $-        property $ \pos t ->-          positionAt1 tproxy pos t === pos-    describe "positionAtN" $-      it "just returns the given position" $-        property $ \pos chunk ->-          positionAtN tproxy pos chunk === pos-    describe "advance1" $ do-      context "when given newline" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l _) ->-            advance1 tproxy w pos '\n' === SourcePos n (l <> pos1) pos1-      context "when given tab" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l c) ->-            advance1 tproxy w pos '\t' === SourcePos n l (toNextTab w c)-      context "when given other character" $-        it "works correctly" $-          property $ \ch w pos@(SourcePos n l c) ->-            (ch /= '\n' && ch /= '\t') ==>-              advance1 tproxy w pos ch === SourcePos n l (c <> pos1)-    describe "advanceN" $-      it "works correctly" $-        advanceN tproxy defaultTabWidth (initialPos "") "something\n\tfoo"-          === SourcePos "" (mkPos 2) (mkPos 12)-    describe "take1_" $ do-      context "when input in empty" $-        it "returns Nothing" $-          take1_ ("" :: T.Text) === Nothing-      context "when input is not empty" $-        it "unconses a token" $-          property $ \s -> not (T.null s) ==>-            take1_ (s :: T.Text) === T.uncons s-    describe "takeN_" $ do-      context "requested length is 0" $-        it "returns Just empty chunk and original stream" $-          property $ \s ->-            takeN_ 0 (s :: T.Text) === Just ("", s)-      context "requested length is greater than 0" $ do-        context "stream is empty" $-          it "returns Nothing" $-            property $ \(Positive n) ->-              takeN_ n ("" :: T.Text) === Nothing-        context "stream is not empty" $-          it "returns a chunk of correct length and rest of the stream" $-            property $ \(Positive n) s -> not (T.null s) ==>-              takeN_ n (s :: T.Text) === Just (T.splitAt n s)-    describe "takeWhile_" $-      it "extracts a chunk that is a prefix consisting of matching tokens" $-        property $ \s ->-          takeWhile_ isLetter s === T.span isLetter s--  describe "Lazy Text instance of Stream" $ do-    describe "tokenToChunk" $-      it "produces the same result as singleton with tokensToChunk" $-        property $ \ch ->-          tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch]-    describe "tokensToChunk" $-      it "list of tokens is isomorphic to chunk" $-        property $ \ts ->-          chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts-    describe "chunkToTokens" $-      it "chunk is isomorphic to list of tokens" $-        property $ \chunk ->-          tokensToChunk tlproxy (chunkToTokens tlproxy chunk) === chunk-    describe "chunkLength" $-      it "returns correct length of given chunk" $-        property $ \chunk ->-          chunkLength tlproxy chunk === fromIntegral (TL.length chunk)-    describe "chunkEmpty" $-      it "only true when chunkLength returns 0" $-        property $ \chunk ->-          chunkEmpty tlproxy chunk === (chunkLength tlproxy chunk <= 0)-    describe "positionAt1" $-      it "just returns the given position" $-        property $ \pos t ->-          positionAt1 tlproxy pos t === pos-    describe "positionAtN" $-      it "just returns the given position" $-        property $ \pos chunk ->-          positionAtN tlproxy pos chunk === pos-    describe "advance1" $ do-      context "when given newline" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l _) ->-            advance1 tlproxy w pos '\n' === SourcePos n (l <> pos1) pos1-      context "when given tab" $-        it "works correctly" $-          property $ \w pos@(SourcePos n l c) ->-            advance1 tlproxy w pos '\t' === SourcePos n l (toNextTab w c)-      context "when given other character" $-        it "works correctly" $-          property $ \ch w pos@(SourcePos n l c) ->-            (ch /= '\n' && ch /= '\t') ==>-              advance1 tlproxy w pos ch === SourcePos n l (c <> pos1)-    describe "advanceN" $-      it "works correctly" $-        advanceN tlproxy defaultTabWidth (initialPos "") "something\n\tfoo"-          === SourcePos "" (mkPos 2) (mkPos 12)-    describe "take1_" $ do-      context "when input in empty" $-        it "returns Nothing" $-          take1_ ("" :: TL.Text) === Nothing-      context "when input is not empty" $-        it "unconses a token" $-          property $ \s -> not (TL.null s) ==>-            take1_ (s :: TL.Text) === TL.uncons s-    describe "takeN_" $ do-      context "requested length is 0" $-        it "returns Just empty chunk and original stream" $-          property $ \s ->-            takeN_ 0 (s :: TL.Text) === Just ("", s)-      context "requested length is greater than 0" $ do-        context "stream is empty" $-          it "returns Nothing" $-            property $ \(Positive n) ->-              takeN_ n ("" :: TL.Text) === Nothing-        context "stream is not empty" $-          it "returns a chunk of correct length and rest of the stream" $-            property $ \(Positive n) s -> not (TL.null s) ==>-              takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s)-    describe "takeWhile_" $-      it "extracts a chunk that is a prefix consisting of matching tokens" $-        property $ \s ->-          takeWhile_ isLetter s === TL.span isLetter s--------------------------------------------------------------------------------- Helpers--toNextTab :: Pos -> Pos -> Pos-toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w)-  where-    w = unPos w'-    c = unPos c'--sproxy :: Proxy String-sproxy = Proxy--bproxy :: Proxy B.ByteString-bproxy = Proxy--blproxy :: Proxy BL.ByteString-blproxy = Proxy--tproxy :: Proxy T.Text-tproxy = Proxy--tlproxy :: Proxy TL.Text-tlproxy = Proxy
− tests/Text/MegaparsecSpec.hs 
@@ -1,1838 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE RecursiveDo       #-}-{-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Text.MegaparsecSpec (spec) where--import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (toUpper, isLetter)-import Data.Foldable (asum, concat)-import Data.Function (on)-import Data.List (isPrefixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, listToMaybe, isJust)-import Data.Monoid-import Data.Proxy-import Data.String-import Data.Void-import Prelude hiding (span, concat)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck hiding (label)-import Text.Megaparsec-import Text.Megaparsec.Char-import qualified Control.Monad.RWS.Lazy      as L-import qualified Control.Monad.RWS.Strict    as S-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.List                   as DL-import qualified Data.List.NonEmpty          as NE-import qualified Data.Semigroup              as G-import qualified Data.Set                    as E-import qualified Data.Text                   as T-import qualified Data.ByteString             as BS--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif--#if !MIN_VERSION_QuickCheck(2,8,2)-instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where-  arbitrary = E.fromList <$> arbitrary-  shrink    = fmap E.fromList . shrink . E.toList-#endif--spec :: Spec-spec = do--  describe "position in custom stream" $ do--    describe "eof" $-      it "updates position in stream correctly" $-        property $ \st -> (not . null . stateInput) st ==> do-          let p = eof :: CustomParser ()-              h = head (stateInput st)-              apos = let (_:|z) = statePos st in spanStart h :| z-          runParser' p st `shouldBe`-            ( st { statePos = apos }-            , Left (err apos $ utok h <> eeof) )--    describe "token" $ do-      context "when input stream is empty" $-        it "signals correct parse error" $-          property $ \st'@State {..} span -> do-            let p = pSpan span-                st = (st' :: State [Span]) { stateInput = [] }-            runParser' p st `shouldBe`-              ( st-              , Left (err statePos $ ueof <> etok span) )-      context "when head of stream matches" $-        it "updates parser state correctly" $-          property $ \st'@State {..} span -> do-            let p = pSpan span-                st = st' { stateInput = span : stateInput }-                npos = spanEnd span :| NE.tail statePos-            runParser' p st `shouldBe`-              ( st { statePos             = npos-                   , stateTokensProcessed = stateTokensProcessed + 1-                   , stateInput           = stateInput }-              , Right span )-      context "when head of stream does not match" $ do-        let checkIt s span =-              let ms = listToMaybe s-              in isJust ms && (spanBody <$> ms) /= Just (spanBody span)-        it "signals correct parse error" $-          property $ \st@State {..} span -> checkIt stateInput span ==> do-            let p = pSpan span-                h = head stateInput-                apos = spanStart h :| NE.tail statePos-            runParser' p st `shouldBe`-              ( st { statePos = apos }-              , Left (err apos $ utok h <> etok span))--    describe "tokens" $-      it "updates position in stream correctly" $-        property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do-          let p = tokens compareTokens ts :: CustomParser [Span]-              compareTokens = (==) `on` fmap spanBody-              compareToken  = (==) `on` spanBody-              il = length . takeWhile id $ zipWith compareToken stateInput ts-              tl = length ts-              consumed = take il stateInput-              (apos, npos) =-                let (pos:|z) = statePos-                    pxy = Proxy :: Proxy [Span]-                in ( positionAt1 pxy pos (head stateInput) :| z-                   , advanceN pxy stateTabWidth pos consumed :| z )-          if | null ts -> runParser' p st `shouldBe` (st, Right [])-             | null stateInput -> runParser' p st `shouldBe`-               ( st-               , Left (err statePos $ ueof <> etoks ts) )-             | il == tl -> runParser' p st `shouldBe`-               ( st { statePos             = npos-                    , stateTokensProcessed = stateTokensProcessed + fromIntegral tl-                    , stateInput           = drop tl stateInput }-               , Right consumed )-             | otherwise -> runParser' p st `shouldBe`-               ( st { statePos = apos }-               , Left (err apos $ utoks (take tl stateInput) <> etoks ts) )--    describe "takeWhileP" $-      it "updates position in stream correctly" $-        property $ \st@State {..} -> do-          let p = takeWhileP Nothing (const True) :: CustomParser [Span]-              st' = st-                { stateInput = []-                , statePos   =-                    case stateInput of-                      [] -> statePos-                      xs -> let _:|z = statePos in spanEnd (last xs) :| z-                , stateTokensProcessed =-                    stateTokensProcessed + length stateInput }-          runParser' p st `shouldBe` (st', Right stateInput)--    describe "takeWhile1P" $ do-      context "when stream is prefixed with matching tokens" $-        it "updates position in stream correctly" $-          property $ \st@State {..} -> not (null stateInput) ==> do-            let p = takeWhile1P Nothing (const True) :: CustomParser [Span]-                st' = st-                  { stateInput = []-                  , statePos   =-                      case stateInput of-                        [] -> statePos-                        xs -> let _:|z = statePos in spanEnd (last xs) :| z-                  , stateTokensProcessed =-                      stateTokensProcessed + length stateInput }-            runParser' p st `shouldBe` (st', Right stateInput)-      context "when stream is not prefixed with at least one matching token" $-        it "updates position in stream correctly" $-          property $ \st@State {..} -> do-            let p = takeWhile1P Nothing (const False) :: CustomParser [Span]-            fst (runParser' p st) `shouldBe` st--    describe "takeP" $ do-      context "when stream has enough tokens" $-        it "updates position in stream correctly" $-          property $ \st@State {..} -> not (null stateInput) ==> do-            let p = takeP Nothing (length stateInput) :: CustomParser [Span]-                st' = st-                  { stateInput = []-                  , statePos   =-                      case stateInput of-                        [] -> statePos-                        xs -> let _:|z = statePos in spanEnd (last xs) :| z-                  , stateTokensProcessed =-                      stateTokensProcessed + length stateInput }-            runParser' p st `shouldBe` (st', Right stateInput)-      context "when stream has not enough tokens" $-        it "updates position in stream correctly" $-          property $ \st@State {..} -> not (null stateInput) ==> do-            let p = takeP Nothing (1 + length stateInput) :: CustomParser [Span]-                (pos:|z) = statePos-                st' = st-                  { statePos = positionAtN-                      (Proxy :: Proxy [Span]) pos stateInput :| z }-            fst (runParser' p st) `shouldBe` st'--    describe "getNextTokenPosition" $ do-      context "when input stream is empty" $-        it "returns Nothing" $-          property $ \st' -> do-            let p :: CustomParser (Maybe SourcePos)-                p = getNextTokenPosition-                st = (st' :: State [Span]) { stateInput = [] }-            runParser' p st `shouldBe` (st, Right Nothing)-      context "when input stream is not empty" $-        it "return the position of start of the next token" $-           property $ \st' h -> do-             let p :: CustomParser (Maybe SourcePos)-                 p = getNextTokenPosition-                 st = st' { stateInput = h : stateInput st' }-             runParser' p st `shouldBe` (st, (Right . Just . spanStart) h)--  describe "ParsecT Semigroup instance" $-    it "the associative operation works" $-      property $ \a b -> do-        let p = pure [a] G.<> pure [b]-        prs p "" `shouldParse` ([a,b] :: [Int])--  describe "ParsecT Monoid instance" $ do-    it "mempty works" $ do-      let p = mempty-      prs p "" `shouldParse` ([] :: [Int])-    it "mappend works" $-      property $ \a b -> do-        let p = pure [a] `mappend` pure [b]-        prs p "" `shouldParse` ([a,b] :: [Int])--  describe "ParsecT IsString instance" $ do-    describe "equivalence to 'string'" $ do-      it "for String" $ property $ \s i ->-        eqParser-          (string s)-          (fromString s)-          (i :: String)-      it "for Text" $ property $ \s i ->-        eqParser-          (string (T.pack s))-          (fromString s)-          (i :: T.Text)-      it "for ByteString" $ property $ \s i ->-        eqParser-          (string (fromString s :: BS.ByteString))-          (fromString s)-          (i :: BS.ByteString)-    it "can handle Unicode" $ do-        let-          r = "פּאַרסער 解析器" :: BS.ByteString-          p :: Parsec Void BS.ByteString BS.ByteString-          p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"]-        parse p "" r `shouldParse` r--  describe "ParsecT Functor instance" $ do-    it "obeys identity law" $-      property $ \n ->-        prs (fmap id (pure (n :: Int))) "" ===-        prs (id (pure n))               ""-    it "obeys composition law" $-      property $ \n m t ->-        let f = (+ m)-            g = (* t)-        in prs (fmap (f . g) (pure (n :: Int))) "" ===-           prs ((fmap f . fmap g) (pure n))     ""--  describe "ParsecT Applicative instance" $ do-    it "obeys identity law" $-      property $ \n ->-        prs (pure id <*> pure (n :: Int)) "" ===-        prs (pure n) ""-    it "obeys composition law" $-      property $ \n m t ->-        let u = pure (+ m)-            v = pure (* t)-            w = pure (n :: Int)-        in prs (pure (.) <*> u <*> v <*> w) "" ===-           prs (u <*> (v <*> w)) ""-    it "obeys homomorphism law" $-      property $ \x m ->-        let f = (+ m)-        in prs (pure f <*> pure (x :: Int)) "" ===-           prs (pure (f x)) ""-    it "obeys interchange law" $-      property $ \n y ->-        let u = pure (+ n)-        in prs (u <*> pure (y :: Int)) "" ===-           prs (pure ($ y) <*> u) ""-    describe "(<*>)" $-      context "when first parser succeeds without consuming" $-        context "when second parser fails consuming input" $-          it "fails consuming input" $ do-            let p = m <*> n-                m = return (\x -> 'a' : x)-                n = string "bc" <* empty-                s = "bc"-            prs  p s `shouldFailWith` err (posN (4 :: Int) s) mempty-            prs' p s `failsLeaving`   ""-    describe "(*>)" $-      it "works correctly" $-        property $ \n m ->-          let u = pure (+ (m :: Int))-              v = pure (n :: Int)-          in prs (u *> v) "" ===-             prs (pure (const id) <*> u <*> v) ""-    describe "(<*)" $-      it "works correctly" $-        property $ \n m ->-          let u = pure (m :: Int)-              v = pure (+ (n :: Int))-          in prs (u <* v) "" === prs (pure const <*> u <*> v) ""--  describe "ParsecT Alternative instance" $ do--    describe "empty" $-      it "always fails" $-        property $ \n ->-          prs (empty <|> pure n) "" `shouldParse` (n :: Integer)--    describe "(<|>)" $ do-      context "with two strings" $ do-        context "stream begins with the first string" $-          it "parses the string" $-            property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do-              let s' = s0 ++ s-                  p = string s0 <|> string s1-              prs  p s' `shouldParse` s0-              prs' p s' `succeedsLeaving` s-        context "stream begins with the second string" $-          it "parses the string" $-            property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do-              let s' = s1 ++ s-                  p = string s0 <|> string s1-              prs  p s' `shouldParse` s1-              prs' p s' `succeedsLeaving` s-        context "when stream does not begin with either string" $-          it "signals correct error message" $-            property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do-              let p = string s0 <|> string s1-                  z = take (max (length s0) (length s1)) s-              prs  p s `shouldFailWith` err posI-                (etoks s0 <>-                 etoks s1 <>-                 (if null s then ueof else utoks z))-      context "with two complex parsers" $ do-        context "when stream begins with matching character" $-          it "parses it" $-            property $ \a b -> a /= b ==> do-              let p = char a <|> (char b *> char a)-                  s = [a]-              prs  p s `shouldParse` a-              prs' p s `succeedsLeaving` ""-        context "when stream begins with only one matching character" $-          it "signals correct parse error" $-            property $ \a b c -> a /= b && a /= c ==> do-              let p = char a <|> (char b *> char a)-                  s = [b,c]-              prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a)-              prs' p s `failsLeaving` [c]-        context "when stream begins with not matching character" $-          it "signals correct parse error" $-            property $ \a b c -> a /= b && a /= c && b /= c ==> do-              let p = char a <|> (char b *> char a)-                  s = [c,b]-              prs  p s `shouldFailWith` err posI (utok c <> etok a <> etok b)-              prs' p s `failsLeaving` s-        context "when stream is emtpy" $-          it "signals correct parse error" $-            property $ \a b -> do-              let p = char a <|> (char b *> char a)-              prs  p "" `shouldFailWith` err posI (ueof <> etok a <> etok b)-      it "associativity of fold over alternatives should not matter" $ do-        let p  = asum [empty, string ">>>", empty, return "foo"] <?> "bar"-            p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"-            bsum = foldl (<|>) empty-            s  = ">>"-        prs p s `shouldBe` prs p' s--    describe "many" $ do-      context "when stream begins with things argument of many parses" $-        it "they are parsed" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = many (char 'a')-                s = abcRow a b c-            prs  p s `shouldParse` replicate a 'a'-            prs' p s `succeedsLeaving` drop a s-      context "when stream does not begin with thing argument of many parses" $-        it "does nothing" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = many (char 'd')-                s = abcRow a b c-            prs  p s `shouldParse` ""-            prs' p s `succeedsLeaving` s-      context "when stream is empty" $-        it "succeeds parsing nothing" $ do-          let p = many (char 'a')-          prs  p "" `shouldParse` ""-      context "when there are two many combinators in a row that parse nothing" $-        it "accumulated hints are reflected in parse error" $ do-          let p = many (char 'a') *> many (char 'b') *> eof-          prs p "c" `shouldFailWith` err posI-            (utok 'c' <> etok 'a' <> etok 'b' <> eeof)-      context "when the argument parser succeeds without consuming" $-        it "is run nevertheless" $-          property $ \n' -> do-            let n = getSmall (getNonNegative n') :: Integer-                p = void . many $ do-                  x <- S.get-                  if x < n then S.modify (+ 1) else empty-                v :: S.State Integer (Either (ParseError Char Void) ())-                v = runParserT p "" ("" :: String)-            S.execState v 0 `shouldBe` n--    describe "some" $ do-      context "when stream begins with things argument of some parses" $-        it "they are parsed" $-          property $ \a' b' c' -> do-            let a = getPositive a'-                [b,c] = getNonNegative <$> [b',c']-                p = some (char 'a')-                s = abcRow a b c-            prs  p s `shouldParse` replicate a 'a'-            prs' p s `succeedsLeaving` drop a s-      context "when stream does not begin with thing argument of some parses" $-        it "signals correct parse error" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = some (char 'd')-                s = abcRow a b c ++ "g"-            prs  p s `shouldFailWith` err posI (utok (head s) <> etok 'd')-            prs' p s `failsLeaving` s-      context "when stream is empty" $-        it "signals correct parse error" $-          property $ \ch -> do-            let p = some (char ch)-            prs  p "" `shouldFailWith` err posI (ueof <> etok ch)-    context "optional" $ do-      context "when stream begins with that optional thing" $-        it "parses it" $-          property $ \a b -> do-            let p = optional (char a) <* char b-                s = [a,b]-            prs  p s `shouldParse` Just a-            prs' p s `succeedsLeaving` ""-      context "when stream does not begin with that optional thing" $-        it "succeeds parsing nothing" $-          property $ \a b -> a /= b ==> do-            let p = optional (char a) <* char b-                s = [b]-            prs  p s `shouldParse` Nothing-            prs' p s `succeedsLeaving` ""-      context "when stream is empty" $-        it "succeeds parsing nothing" $-          property $ \a -> do-            let p = optional (char a)-            prs  p "" `shouldParse` Nothing--  describe "ParsecT Monad instance" $ do-    it "satisfies left identity law" $-      property $ \a k' -> do-        let k = return . (+ k')-            p = return (a :: Int) >>= k-        prs p "" `shouldBe` prs (k a) ""-    it "satisfies right identity law" $-      property $ \a -> do-        let m = return (a :: Int)-            p = m >>= return-        prs p "" `shouldBe` prs m ""-    it "satisfies associativity law" $-      property $ \m' k' h' -> do-        let m = return (m' :: Int)-            k = return . (+ k')-            h = return . (* h')-            p = m >>= (\x -> k x >>= h)-            p' = (m >>= k) >>= h-        prs p "" `shouldBe` prs p' ""-    it "fails signals correct parse error" $-      property $ \msg -> do-        let p = fail msg :: Parsec Void String ()-        prs p "" `shouldFailWith` errFancy posI (fancy $ ErrorFail msg)-    it "pure is the same as return" $-      property $ \n ->-        prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""-    it "(<*>) is the same as ap" $-      property $ \m' k' -> do-        let m = return (m' :: Int)-            k = return (+ k')-        prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""--  describe "ParsecT MonadFail instance" $-    describe "fail" $-      it "signals correct parse error" $-        property $ \s msg -> do-          let p = void (fail msg)-          prs  p s `shouldFailWith` errFancy posI (fancy $ ErrorFail msg)-          prs' p s `failsLeaving` s--  describe "ParsecT MonadIO instance" $-    it "liftIO works" $-      property $ \n -> do-        let p = liftIO (return n) :: ParsecT Void String IO Integer-        runParserT p "" "" `shouldReturn` Right n--  describe "ParsecT MonadFix instance" $-    it "withRange works" $ do-      let-        withRange-          :: (MonadParsec e s m, MonadFix m)-          => ((SourcePos,SourcePos) -> m a)-          -> m a-        withRange f = do-          Just p1 <- getNextTokenPosition-          rec-            r <- f (p1, p2)-            p2 <- getPosition-          return r-        p :: Parsec Void String (SourcePos,SourcePos)-        p = withRange $ \pp -> pp <$ string "ab"-      runParser p "" "abcd"-        `shouldBe` Right-        ( SourcePos "" (mkPos 1) (mkPos 1)-        , SourcePos "" (mkPos 1) (mkPos 3)-        )--  describe "ParsecT MonadReader instance" $ do--    describe "ask" $-      it "returns correct value of context" $-        property $ \n -> do-          let p = ask :: ParsecT Void String (Reader Integer) Integer-          runReader (runParserT p "" "") n `shouldBe` Right n--    describe "local" $-      it "modifies reader context correctly" $-        property $ \n k -> do-          let p = local (+ k) ask :: ParsecT Void String (Reader Integer) Integer-          runReader (runParserT p "" "") n `shouldBe` Right (n + k)--  describe "ParsecT MonadState instance" $ do--    describe "get" $-      it "returns correct state value" $-        property $ \n -> do-          let p = L.get :: ParsecT Void String (L.State Integer) Integer-          L.evalState (runParserT p "" "") n `shouldBe` Right n-    describe "put" $-      it "replaces state value" $-        property $ \a b -> do-          let p = L.put b :: ParsecT Void String (L.State Integer) ()-          L.execState (runParserT p "" "") a `shouldBe` b--  describe "ParsecT MonadCont instance" $--    describe "callCC" $-      it "works properly" $-        property $ \a b -> do-          let p :: ParsecT Void String (Cont (Either (ParseError Char Void) Integer)) Integer-              p = callCC $ \e -> when (a > b) (e a) >> return b-          runCont (runParserT p "" "") id `shouldBe` Right (max a b)--  describe "ParsecT MonadError instance" $ do--    describe "throwError" $-      it "throws the error" $-        property $ \a b -> do-          let p :: ParsecT Void String (Except Integer) Integer-              p = throwError a >> return b-          runExcept (runParserT p "" "") `shouldBe` Left a--    describe "catchError" $-      it "catches the error" $-        property $ \a b -> do-          let p :: ParsecT Void String (Except Integer) Integer-              p = (throwError a >> return b) `catchError` handler-              handler e = return (e + b)-          runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)--  describe "primitive combinators" $ do--    describe "failure" $-      it "signals correct parse error" $-        property $ \us ps -> do-          let p :: MonadParsec Void String m => m ()-              p = void (failure us ps)-          grs p "" (`shouldFailWith` TrivialError posI us ps)--    describe "fancyFailure" $-      it "singals correct parse error" $-        property $ \xs -> do-          let p :: MonadParsec Void String m => m ()-              p = void (fancyFailure xs)-          grs p "" (`shouldFailWith` FancyError posI xs)--    describe "label" $ do-      context "when inner parser succeeds consuming input" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Void String m => m Char-                  p = label lbl (char a) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-        context "inner parser produces hints" $-          it "replaces the last hint with “the rest of <label>”" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Void String m => m String-                  p = label lbl (many (char a)) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (elabel $ "the rest of " ++ lbl))-              grs' p s (`failsLeaving` "")-      context "when inner parser consumes and fails" $-        it "reports parse error without modification" $-          property $ \lbl a b c -> not (null lbl) && b /= c ==> do-            let p :: MonadParsec Void String m => m Char-                p = label lbl (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Void String m => m Char-                  p = label lbl (return a) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-        context "inner parser produces hints" $-          it "replaces the last hint with given label" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Void String m => m String-                  p = label lbl (many (char a)) <* empty-              grs p "" (`shouldFailWith` err posI (elabel lbl))-      context "when inner parser fails without consuming" $-        it "is mentioned in parse error via its label" $-          property $ \lbl -> not (null lbl) ==> do-            let p :: MonadParsec Void String m => m ()-                p = label lbl empty-            grs p "" (`shouldFailWith` err posI (elabel lbl))--    describe "hidden" $ do-      context "when inner parser succeeds consuming input" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \a -> do-              let p :: MonadParsec Void String m => m Char-                  p = hidden (char a) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-        context "inner parser produces hints" $-          it "hides the parser in the error message" $-            property $ \a -> do-              let p :: MonadParsec Void String m => m String-                  p = hidden (many (char a)) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-      context "when inner parser consumes and fails" $-        it "reports parse error without modification" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Void String m => m Char-                p = hidden (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \a -> do-              let p :: MonadParsec Void String m => m Char-                  p = hidden (return a) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-        context "inner parser produces hints" $-          it "hides the parser in the error message" $-            property $ \a -> do-              let p :: MonadParsec Void String m => m String-                  p = hidden (many (char a)) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-      context "when inner parser fails without consuming" $-        it "hides the parser in the error message" $ do-          let p :: MonadParsec Void String m => m ()-              p = hidden empty-          grs p "" (`shouldFailWith` err posI mempty)--    describe "try" $ do-      context "when inner parser succeeds consuming" $-        it "try has no effect" $-          property $ \a -> do-            let p :: MonadParsec Void String m => m Char-                p = try (char a)-                s = [a]-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` "")-      context "when inner parser fails consuming" $ do-        it "backtracks, it appears as if the parser has not consumed anything" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Void String m => m Char-                p = try (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` s)-        it "hints from the inner parse error do not leak" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Void String m => m (Maybe Char)-                p = (optional . try) (char a *> char b) <* empty-                s = [a,c]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser succeeds without consuming" $-        it "try has no effect" $-          property $ \a -> do-            let p :: MonadParsec Void String m => m Char-                p = try (return a)-            grs p "" (`shouldParse` a)-      context "when inner parser fails without consuming" $-        it "try backtracks parser state anyway" $-          property $ \w -> do-            let p :: MonadParsec Void String m => m Char-                p = try (setTabWidth w *> empty)-            grs  p "" (`shouldFailWith` err posI mempty)-            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)--    describe "lookAhead" $ do-      context "when inner parser succeeds consuming" $ do-        it "result is returned but parser state is not changed" $-          property $ \a w -> do-            let p :: MonadParsec Void String m => m Pos-                p = lookAhead (setTabWidth w *> char a) *> getTabWidth-                s = [a]-            grs  p s (`shouldParse` defaultTabWidth)-            grs' p s (`succeedsLeaving` s)-        it "hints are not preserved" $-          property $ \a -> do-            let p :: MonadParsec Void String m => m String-                p = lookAhead (many (char a)) <* empty-                s = [a]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser fails consuming" $-        it "error message is reported as usual" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Void String m => m Char-                p = lookAhead (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        it "result is returned but parser state in not changed" $-          property $ \a w -> do-            let p :: MonadParsec Void String m => m Pos-                p = lookAhead (setTabWidth w *> char a) *> getTabWidth-                s = [a]-            grs  p s (`shouldParse` defaultTabWidth)-            grs' p s (`succeedsLeaving` s)-        it "hints are not preserved" $-          property $ \a b -> a /= b ==> do-            let p :: MonadParsec Void String m => m String-                p = lookAhead (many (char a)) <* empty-                s = [b]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser fails without consuming" $-        it "error message is reported as usual" $ do-          let p :: MonadParsec Void String m => m Char-              p = lookAhead empty-          grs p "" (`shouldFailWith` err posI mempty)--    describe "notFollowedBy" $ do-      context "when inner parser succeeds consuming" $-        it "signals correct parse error" $-          property $ \a w -> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (setTabWidth w <* char a)-                s = [a]-            grs  p s (`shouldFailWith` err posI (utok a))-            grs' p s (`failsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-      context "when inner parser fails consuming" $ do-        it "succeeds without consuming" $-          property $ \a b c w -> b /= c ==> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (setTabWidth w *> char a *> char b)-                s = [a,c]-            grs' p s (`succeedsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-        it "hints are not preserved" $-          property $ \a b -> a /= b ==> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (char b *> many (char a) <* char a) <* empty-                s = [b,b]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser succeeds without consuming" $-        it "signals correct parse error" $-          property $ \a w -> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (setTabWidth w *> return a)-                s = [a]-            grs  p s (`shouldFailWith` err posI (utok a))-            grs' p s (`failsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-      context "when inner parser fails without consuming" $ do-        it "succeeds without consuming" $-          property $ \w -> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (setTabWidth w *> empty)-            grs  p "" (`shouldParse` ())-            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-        it "hints are not preserved" $-          property $ \a -> do-            let p :: MonadParsec Void String m => m ()-                p = notFollowedBy (many (char a) <* char a) <* empty-                s = ""-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)--    describe "withRecovery" $ do-      context "when inner parser succeeds consuming" $-        it "the result is returned as usual" $-          property $ \a as -> do-            let p :: MonadParsec Void String m => m (Maybe Char)-                p = withRecovery (const $ return Nothing) (pure <$> char a)-                s = a : as-            grs  p s (`shouldParse` Just a)-            grs' p s (`succeedsLeaving` as)-      context "when inner parser fails consuming" $ do-        context "when recovering parser succeeds consuming input" $ do-          it "its result is returned and position is advanced" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ string (c : as))-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-              grs' p s (`succeedsLeaving` "")-          it "hints are not preserved" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ string (c : as))-                        (Right <$> char a <* many (char b) <* char b) <* empty-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (length s) s) mempty)-              grs' p s (`failsLeaving` "")-        context "when recovering parser fails consuming input" $-          it "the original parse error (and state) is reported" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ char c <* empty)-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-              grs' p s (`failsLeaving` (c : as))-        context "when recovering parser succeeds without consuming" $ do-          it "its result is returned (and state)" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (return . Left) (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-              grs' p s (`succeedsLeaving` (c : as))-          it "original hints are preserved" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (return . Left)-                        (Right <$> char a <* many (char b) <* char b) <* empty-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (etok b))-              grs' p s (`failsLeaving` (c:as))-        context "when recovering parser fails without consuming" $-          it "the original parse error (and state) is reported" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ empty)-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-              grs' p s (`failsLeaving` (c : as))-      context "when inner parser succeeds without consuming" $-        it "the result is returned as usual" $-          property $ \a s -> do-            let p :: MonadParsec Void String m => m (Maybe Char)-                p = withRecovery (const $ return Nothing) (return a)-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` s)-      context "when inner parser fails without consuming" $ do-        context "when recovering parser succeeds consuming input" $-          it "its result is returned and position is advanced" $-            property $ \a as -> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ string s) empty-                  s = a : as-              grs  p s (`shouldParse` Left (err posI mempty))-              grs' p s (`succeedsLeaving` "")-        context "when recovering parser fails consuming input" $-          it "the original parse error (and state) is reported" $-            property $ \a b as -> a /= b ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ char a <* char b <* empty)-                        (Right <$> empty)-                  s = a : as-              grs  p s (`shouldFailWith` err posI mempty)-              grs' p s (`failsLeaving` s)-        context "when recovering parser succeeds without consuming" $ do-          it "its result is returned (and state)" $-            property $ \s -> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (return . Left) empty-              grs  p s (`shouldParse` Left (err posI mempty))-              grs' p s (`succeedsLeaving` s)-          it "original hints are preserved" $-            property $ \a b as -> a /= b ==> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) String)-                  p = withRecovery (return . Left)-                        (Right <$> many (char a) <* empty) <* empty-                  s = b : as-              grs  p s (`shouldFailWith` err posI (etok a))-              grs' p s (`failsLeaving` s)-        context "when recovering parser fails without consuming" $-          it "the original parse error (and state) is reported" $-            property $ \s -> do-              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                  p = withRecovery (\e -> Left e <$ empty) empty-              grs  p s (`shouldFailWith` err posI mempty)-              grs' p s (`failsLeaving` s)-      it "works in complex situations too" $-        property $ \a' b' c' -> do-          let p :: MonadParsec Void String m => m (Either (ParseError Char Void) String)-              p = let g = count' 1 3 . char in v <$>-                withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'-              v (Right x) y = Right (x ++ y)-              v (Left  m) _ = Left m-              ma = if a < 3 then etok 'a' else mempty-              s = abcRow a b c-              [a,b,c] = getNonNegative <$> [a',b',c']-              f = flip shouldFailWith-              z = flip shouldParse-              r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))-                | a == 0 && b == 0 && c >  3 = f (err posI (utok 'c' <> etok 'a'))-                | a == 0 && b == 0           = f (err posI (utok 'c' <> etok 'a'))-                | a == 0 && b >  3           = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'c'))-                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'c'))-                | a == 0 &&           c >  3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))-                | a == 0                     = z (Left (err posI (utok 'b' <> etok 'a')))-                | a >  3                     = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))-                |           b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))-                |           b == 0 && c >  3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))-                |           b == 0           = z (Right s)-                | otherwise                  = f (err (posN a s) (utok 'b' <> etok 'c' <> ma))-          grs (p <* eof) s r--    describe "observing" $ do-      context "when inner parser succeeds consuming" $-        it "returns its result in Right" $-          property $ \a as -> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                p = observing (char a)-                s = a : as-            grs  p s (`shouldParse` Right a)-            grs' p s (`succeedsLeaving` as)-      context "when inner parser fails consuming" $ do-        it "returns its parse error in Left preserving state" $-          property $ \a b c as -> b /= c ==> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                p = observing (char a *> char b)-                s = a : c : as-            grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-            grs' p s (`succeedsLeaving` (c:as))-        it "does not create any hints" $-          property $ \a b c as -> b /= c ==> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                p = observing (char a *> char b) *> empty-                s = a : c : as-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-            grs' p s (`failsLeaving` (c:as))-      context "when inner parser succeeds without consuming" $-        it "returns its result in Right" $-          property $ \a s -> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                p = observing (return a)-            grs  p s (`shouldParse` Right a)-            grs' p s (`succeedsLeaving` s)-      context "when inner parser fails without consuming" $ do-        it "returns its parse error in Left preserving state" $-          property $ \s -> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) ())-                p = observing empty-            grs  p s (`shouldParse` Left (err posI mempty))-            grs' p s (`succeedsLeaving` s)-        it "creates correct hints" $-          property $ \a b as -> a /= b ==> do-            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)-                p = observing (char a) <* empty-                s = b : as-            grs  p s (`shouldFailWith` err posI (etok a))-            grs' p s (`failsLeaving` (b:as))--    describe "eof" $ do-      context "when input stream is empty" $-        it "succeeds" $-          grs eof "" (`shouldParse` ())-      context "when input stream is not empty" $-        it "signals correct error message" $-          property $ \a as -> do-            let s = a : as-            grs  eof s (`shouldFailWith` err posI (utok a <> eeof))-            grs' eof s (`failsLeaving` s)--    describe "token" $ do-      let f x = Tokens (nes x)-          testChar a x =-            if x == a-              then Right x-              else Left (pure (f x), E.singleton (f a))-      context "when supplied predicate is satisfied" $-        it "succeeds" $-          property $ \a as mtok -> do-            let p :: MonadParsec Void String m => m Char-                p = token (testChar a) mtok-                s = a : as-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` as)-      context "when supplied predicate is not satisfied" $-        it "signals correct parse error" $-          property $ \a b as mtok -> a /= b ==> do-            let p :: MonadParsec Void String m => m Char-                p = token (testChar b) mtok-                s = a : as-                us = pure (Tokens $ nes a)-                ps = E.singleton (Tokens $ nes b)-            grs  p s (`shouldFailWith` TrivialError posI us ps)-            grs' p s (`failsLeaving` s)-      context "when stream is empty" $-        it "signals correct parse error" $-          property $ \a mtok -> do-            let p :: MonadParsec Void String m => m Char-                p = token (testChar a) mtok-                us = pure EndOfInput-                ps = maybe E.empty (E.singleton . Tokens . nes) mtok-            grs p "" (`shouldFailWith` TrivialError posI us ps)--    describe "tokens" $ do-      context "when stream is prefixed with given string" $-        it "parses the string" $-          property $ \str s -> do-            let p :: MonadParsec Void String m => m String-                p = tokens (==) str-                s' = str ++ s-            grs  p s' (`shouldParse` str)-            grs' p s' (`succeedsLeaving` s)-      context "when stream is not prefixed with given string" $-        it "signals correct parse error" $-          property $ \str s -> not (str `isPrefixOf` s) ==> do-            let p :: MonadParsec Void String m => m String-                p = tokens (==) str-                z = take (length str) s-            grs  p s (`shouldFailWith` err posI (utoks z <> etoks str))-            grs' p s (`failsLeaving` s)-      context "when matching the empty string" $-        it "eok continuation is used" $-          property $ \str s -> do-            let p :: MonadParsec Void String m => m String-                p = (tokens (==) "" <* empty) <|> pure str-            grs  p s (`shouldParse` str)-            grs' p s (`succeedsLeaving` s)--    describe "takeWhileP" $ do-      context "when stream is not empty" $-        it "consumes all matching tokens, zero or more" $-          property $ \s -> not (null s) ==> do-            let p :: MonadParsec Void String m => m String-                p = takeWhileP Nothing isLetter-                (z,zs) = DL.span isLetter s-            grs  p s (`shouldParse` z)-            grs' p s (`succeedsLeaving` zs)-      context "when stream is empty" $-        it "succeeds returning empty chunk" $ do-          let p :: MonadParsec Void String m => m String-              p = takeWhileP Nothing isLetter-          grs  p "" (`shouldParse` "")-          grs' p "" (`succeedsLeaving` "")-      context "with two takeWhileP in a row (testing hints)" $ do-        let p :: MonadParsec Void String m => m String-            p = do-              void $ takeWhileP (Just "foo") (== 'a')-              void $ takeWhileP (Just "bar") (== 'b')-              empty-        context "when the second one does not consume" $-          it "hints are combined properly" $ do-            let s = "aaa"-                pe = err (posN 3 s) (elabel "foo" <> elabel "bar")-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` "")-        context "when the second one consumes" $-          it "only hints of the second one affect parse error" $ do-            let s = "aaabbb"-                pe = err (posN 6 s) (elabel "bar")-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` "")-      context "without label (testing hints)" $-        it "there are no hints" $ do-          let p :: MonadParsec Void String m => m String-              p = takeWhileP Nothing (== 'a') <* empty-              s = "aaa"-          grs  p s (`shouldFailWith` err (posN 3 s) mempty)-          grs' p s (`failsLeaving` "")--    describe "takeWhile1P" $ do-      context "when stream is prefixed with matching tokens" $-        it "consumes the tokens" $-          property $ \s' -> do-            let p :: MonadParsec Void String m => m String-                p = takeWhile1P Nothing isLetter-                s = 'a' : s'-                (z,zs) = DL.span isLetter s-            grs  p s (`shouldParse` z)-            grs' p s (`succeedsLeaving` zs)-      context "when stream is not prefixed with at least one matching token" $-        it "signals correct parse error" $-          property $ \s' -> do-            let p :: MonadParsec Void String m => m String-                p = takeWhile1P (Just "foo") isLetter-                s = '3' : s'-                pe = err posI (utok '3' <> elabel "foo")-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` s)-      context "when stream is empty" $ do-        context "with label" $-          it "signals correct parse error" $ do-            let p :: MonadParsec Void String m => m String-                p = takeWhile1P (Just "foo") isLetter-                pe = err posI (ueof <> elabel "foo")-            grs  p "" (`shouldFailWith` pe)-            grs' p "" (`failsLeaving` "")-        context "without label" $-          it "signals correct parse error" $ do-            let p :: MonadParsec Void String m => m String-                p = takeWhile1P Nothing isLetter-                pe = err posI ueof-            grs  p "" (`shouldFailWith` pe)-            grs' p "" (`failsLeaving` "")-      context "with two takeWhile1P in a row (testing hints)" $ do-        let p :: MonadParsec Void String m => m String-            p = do-              void $ takeWhile1P (Just "foo") (== 'a')-              void $ takeWhile1P (Just "bar") (== 'b')-              empty-        context "when the second one does not consume" $-          it "hints are combined properly" $ do-            let s = "aaa"-                pe = err (posN 3 s) (ueof <> elabel "foo" <> elabel "bar")-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` "")-        context "when the second one consumes" $-          it "only hints of the second one affect parse error" $ do-            let s = "aaabbb"-                pe = err (posN 6 s) (elabel "bar")-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` "")-      context "without label (testing hints)" $-        it "there are no hints" $ do-          let p :: MonadParsec Void String m => m String-              p = takeWhile1P Nothing (== 'a') <* empty-              s = "aaa"-          grs  p s (`shouldFailWith` err (posN 3 s) mempty)-          grs' p s (`failsLeaving` "")--    describe "takeP" $ do-      context "when taking 0 tokens" $ do-        context "when stream is empty" $-          it "succeeds returning zero-length chunk" $ do-            let p :: MonadParsec Void String m => m String-                p = takeP Nothing 0-            grs  p "" (`shouldParse` "")-        context "when stream is not empty" $-          it "succeeds returning zero-length chunk" $-            property $ \s -> not (null s) ==> do-              let p :: MonadParsec Void String m => m String-                  p = takeP Nothing 0-              grs  p s (`shouldParse` "")-              grs' p s (`succeedsLeaving` s)-      context "when taking >0 tokens" $ do-        context "when stream is empty" $ do-          context "with label" $-            it "signals correct parse error" $-              property $ \(Positive n) -> do-                let p :: MonadParsec Void String m => m String-                    p = takeP (Just "foo") n-                    pe = err posI (ueof <> elabel "foo")-                grs  p "" (`shouldFailWith` pe)-                grs' p "" (`failsLeaving`   "")-          context "without label" $-            it "signals correct parse error" $-              property $ \(Positive n) -> do-                let p :: MonadParsec Void String m => m String-                    p = takeP Nothing n-                    pe = err posI ueof-                grs  p "" (`shouldFailWith` pe)-        context "when stream has not enough tokens" $-            it "signals correct parse error" $-              property $ \(Positive n) s -> length s < n && not (null s) ==> do-                let p :: MonadParsec Void String m => m String-                    p = takeP (Just "foo") n-                    pe = err (posN n s) (ueof <> elabel "foo")-                grs  p s (`shouldFailWith` pe)-                grs' p s (`failsLeaving` s)-        context "when stream has enough tokens" $-          it "succeeds returning the extracted tokens" $-            property $ \(Positive n) s -> length s >= n ==> do-              let p :: MonadParsec Void String m => m String-                  p = takeP (Just "foo") n-                  (s0,s1) = splitAt n s-              grs  p s (`shouldParse` s0)-              grs' p s (`succeedsLeaving` s1)-      context "when failing right after takeP (testing hints)" $-        it "there are no hints to influence the parse error" $-          property $ \(Positive n) s -> length s >= n ==> do-            let p :: MonadParsec Void String m => m String-                p = takeP (Just "foo") n <* empty-                pe = err (posN n s) mempty-            grs  p s (`shouldFailWith` pe)-            grs' p s (`failsLeaving` drop n s)--  describe "derivatives from primitive combinators" $ do--    describe "unexpected" $-      it "signals correct parse error" $-        property $ \item -> do-          let p :: MonadParsec Void String m => m ()-              p = void (unexpected item)-          grs p "" (`shouldFailWith` TrivialError posI (pure item) E.empty)--    describe "customFailure" $-      it "signals correct parse error" $-        property $ \n st -> do-          let p :: MonadParsec Int String m => m ()-              p = void (customFailure n)-              xs = E.singleton (ErrorCustom n)-          runParser  p "" (stateInput st) `shouldFailWith` FancyError posI xs-          runParser' p st `failsLeaving` stateInput st--    describe "match" $-      it "return consumed tokens along with the result" $-        property $ \str -> do-          let p  = match (string str)-          prs  p str `shouldParse`     (str,str)-          prs' p str `succeedsLeaving` ""--    describe "region" $ do-      context "when inner parser succeeds" $-        it "has no effect" $-          property $ \st e n -> do-            let p :: Parser Int-                p = region (const e) (pure n)-            runParser' p st `shouldBe` (st, Right (n :: Int))-      context "when inner parser fails" $-        it "the given function is used on the parse error" $-          property $ \st' e pos' -> do-            let p :: Parsec Int String Int-                p = region f $-                  case e of-                    TrivialError _ us ps -> failure us ps-                    FancyError   _ xs    -> fancyFailure   xs-                f (TrivialError pos us ps) = FancyError-                  (max pos pos')-                  (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)-                f (FancyError pos xs) = FancyError-                  (max pos pos')-                  (E.singleton . ErrorCustom $ E.size xs)-                r = FancyError-                  (max (errorPos e) pos')-                  (E.singleton . ErrorCustom $-                    case e of-                      TrivialError _ us ps -> maybe 0 (const 1) us + E.size ps-                      FancyError   _ xs    -> E.size xs )-                finalPos = max (errorPos e) pos'-                st = st' { statePos = errorPos e }-            runParser' p st `shouldBe` (st { statePos = finalPos }, Left r)--    describe "takeRest" $-      it "returns rest of the input" $-        property $ \st@State {..} -> do-          let p :: Parser String-              p = takeRest-              (pos:|z) = statePos-              st' = st-                { stateInput = []-                , statePos   = advanceN-                    (Proxy :: Proxy String)-                    stateTabWidth-                    pos-                    stateInput :| z-                , stateTokensProcessed =-                    stateTokensProcessed + length stateInput }-          runParser' p st `shouldBe` (st', Right stateInput)--    describe "atEnd" $ do-      let p, p' :: Parser Bool-          p  = atEnd-          p' = p <* empty-      context "when stream is empty" $ do-        it "returns True" $-          prs p "" `shouldParse` True-        it "does not produce hints" $-          prs p' "" `shouldFailWith` err posI mempty-      context "when stream is not empty" $ do-        it "returns False" $-          property $ \s -> not (null s) ==> do-            prs  p s `shouldParse` False-            prs' p s `succeedsLeaving` s-        it "does not produce hints" $-          property $ \s -> not (null s) ==> do-            prs  p' s `shouldFailWith` err posI mempty-            prs' p' s `failsLeaving` s--  describe "combinators for manipulating parser state" $ do--    describe "setInput and getInput" $-      it "sets input and gets it back" $-        property $ \s -> do-          let p = do-                st0 <- getInput-                guard (null st0)-                setInput s-                result <- string s-                st1 <- getInput-                guard (null st1)-                return result-          prs p "" `shouldParse` s--    describe "setPosition and getPosition" $-      it "sets position and gets it back" $-        property $ \st pos -> do-          let p :: Parser SourcePos-              p = setPosition pos >> getPosition-              f (State s (_:|xs) tp w) y = State s (y:|xs) tp w-          runParser' p st `shouldBe` (f st pos, Right pos)--    describe "pushPosition" $-      it "adds a layer to position stack and parser continues on that level" $-        property $ \st pos ->  do-          let p :: Parser ()-              p = pushPosition pos-          fst (runParser' p st) `shouldBe`-            st { statePos = NE.cons pos (statePos st) }--    describe "popPosition" $-      it "removes a layer from position stack" $-        property $ \st -> do-          let p :: Parser ()-              p = popPosition-              pos = statePos st-          fst (runParser' p st) `shouldBe`-            st { statePos = fromMaybe pos (snd (NE.uncons pos)) }--    describe "setTokensProcessed and getTokensProcessed" $-      it "sets number of processed toknes and gets it back" $-        property $ \tp -> do-          let p = setTokensProcessed tp >> getTokensProcessed-          prs p "" `shouldParse` tp--    describe "setTabWidth and getTabWidth" $-      it "sets tab width and gets it back" $-        property $ \w -> do-          let p = setTabWidth w >> getTabWidth-          prs p "" `shouldParse` w--    describe "setParserState and getParserState" $-      it "sets parser state and gets it back" $-        property $ \s1 s2 -> do-          let p :: MonadParsec Void String m => m (State String)-              p = do-                st <- getParserState-                guard (st == State s posI 0 defaultTabWidth)-                setParserState s1-                updateParserState (f s2)-                liftM2 const getParserState (setInput "")-              f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w-              s = ""-          grs p s (`shouldParse` f s2 s1)--  describe "running a parser" $ do-    describe "parseMaybe" $-      it "returns result on success and Nothing on failure" $-        property $ \s s' -> do-          let p = string s' :: Parser String-          parseMaybe p s `shouldBe`-            if s == s' then Just s else Nothing--    describe "runParser'" $-      it "works" $-        property $ \st s -> do-          let p = string s-          runParser' p st `shouldBe` emulateStrParsing st s--    describe "runParserT'" $-      it "works" $-        property $ \st s -> do-          let p = string s-          runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s--  describe "MonadParsec instance of ReaderT" $ do--    describe "try" $-      it "generally works" $-        property $ \pre ch1 ch2 -> do-          let s1 = pre : [ch1]-              s2 = pre : [ch2]-              getS1 = asks fst-              getS2 = asks snd-              p = try (g =<< getS1) <|> (g =<< getS2)-              g = sequence . fmap char-              s = [pre]-          prs (runReaderT p (s1, s2)) s `shouldFailWith`-            err (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \a' b' c' -> do-          let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar-              [a,b,c] = getNonNegative <$> [a',b',c']-              s = abcRow a b c-          if b > 0 || c > 0-            then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'-            else prs (runReaderT p 'a') s `shouldFailWith`-                   err (posN a s) (ueof <> etok 'a')--  describe "MonadParsec instance of lazy StateT" $ do--    describe "(<|>)" $-      it "generally works" $-        property $ \n -> do-          let p = L.put n >>-                ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get-          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "lookAhead" $-      it "generally works" $-        property $ \n -> do-          let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get-          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \n -> do-          let p = do-                L.put n-                let notEof = notFollowedBy (L.modify (* 2) >> eof)-                some (try (anyChar <* notEof)) <* char 'x'-          prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect state" $-          property $ \m n -> do-            let p = do-                  L.put m-                  observing (L.modify (+ n))-            prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)-      context "when inner parser fails" $-        it "cannot affect state" $-          property $ \m n -> do-            let p = do-                  L.put m-                  observing (L.modify (+ n) <* empty)-            prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)--  describe "MonadParsec instance of strict StateT" $ do--    describe "(<|>)" $-      it "generally works" $-        property $ \n -> do-          let p = S.put n >>-                ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get-          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "lookAhead" $-      it "generally works" $-        property $ \n -> do-          let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get-          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \n -> do-          let p = do-                S.put n-                let notEof = notFollowedBy (S.modify (* 2) >> eof)-                some (try (anyChar <* notEof)) <* char 'x'-          prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect state" $-          property $ \m n -> do-            let p = do-                  S.put m-                  observing (L.modify (+ n))-            prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)-      context "when inner parser fails" $-        it "cannot affect state" $-          property $ \m n -> do-            let p = do-                  S.put m-                  observing (L.modify (+ n) <* empty)-            prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)--  describe "MonadParsec instance of lazy WriterT" $ do--    it "generally works" $-      property $ \pre post -> do-        let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x-            loggedEof    = eof >> L.tell "EOF"-            p = do-              L.tell pre-              cs <- L.censor (fmap toUpper) $-                some (try (loggedLetter <* notFollowedBy loggedEof))-              L.tell post-              void loggedLetter-              return cs-        prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")--    describe "lookAhead" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (L.tell [w])-          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "notFollowedBy" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (L.tell [w] <* char 'a')-          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect log" $-          property $ \n -> do-            let p = observing (L.tell $ Sum n)-            prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)-      context "when inner parser fails" $-        it "cannot affect log" $-          property $ \n -> do-            let p = observing (L.tell (Sum n) <* empty)-            prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)--  describe "MonadParsec instance of strict WriterT" $ do--    it "generally works" $-      property $ \pre post -> do-        let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x-            loggedEof    = eof >> S.tell "EOF"-            p = do-              S.tell pre-              cs <- L.censor (fmap toUpper) $-                some (try (loggedLetter <* notFollowedBy loggedEof))-              S.tell post-              void loggedLetter-              return cs-        prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")--    describe "lookAhead" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (S.tell [w])-          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "notFollowedBy" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (S.tell [w] <* char 'a')-          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect log" $-          property $ \n -> do-            let p = observing (S.tell $ Sum n)-            prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)-      context "when inner parser fails" $-        it "cannot affect log" $-          property $ \n -> do-            let p = observing (S.tell (Sum n) <* empty)-            prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)--  describe "MonadParsec instance of lazy RWST" $ do--    describe "label" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = label "a" ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "try" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = try ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "lookAhead" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = lookAhead ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (L.tell [w])-          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = lookAhead (L.put s1)-          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "notFollowedBy" $ do-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (L.tell [w] <* char 'a')-          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = notFollowedBy (L.put s1 <* char 'a')-          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "withRecovery" $ do-      it "allows main parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "allows recovering parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "observing" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = observing ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            (Right (r, s), s, mempty :: [Int])-      context "when the inner parser fails" $-        it "backtracks state" $-          property $ \r s0 s1 -> (s0 /= s1) ==> do-            let p = observing (L.put s1 <* empty)-            prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`-              (Left (err posI mempty), s0, mempty :: [Int])--  describe "MonadParsec instance of strict RWST" $ do--    describe "label" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = label "a" ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "try" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = try ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "lookAhead" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = lookAhead ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (S.tell [w])-          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = lookAhead (S.put s1)-          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "notFollowedBy" $ do-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (S.tell [w] <* char 'a')-          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = notFollowedBy (S.put s1 <* char 'a')-          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "withRecovery" $ do-      it "allows main parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "allows recovering parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "observing" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = observing ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            (Right (r, s), s, mempty :: [Int])-      context "when the inner parser fails" $-        it "backtracks state" $-          property $ \r s0 s1 -> (s0 /= s1) ==> do-            let p = observing (S.put s1 <* empty)-            prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`-              (Left (err posI mempty), s0, mempty :: [Int])--  describe "dbg" $ do-    -- NOTE We don't test properties here to avoid flood of debugging output-    -- when the test runs.-    context "when inner parser succeeds consuming input" $ do-      it "has no effect on how parser works" $ do-        let p = dbg "char" (char 'a')-            s = "ab"-        prs  p s `shouldParse` 'a'-        prs' p s `succeedsLeaving` "b"-      it "its hints are preserved" $ do-        let p = dbg "many chars" (many (char 'a')) <* empty-            s = "abcd"-        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (etok 'a')-        prs' p s `failsLeaving` "bcd"-    context "when inner parser fails consuming input" $-      it "has no effect on how parser works" $ do-        let p = dbg "chars" (char 'a' *> char 'c')-            s = "abc"-        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')-        prs' p s `failsLeaving` "bc"-    context "when inner parser succeeds without consuming" $ do-      it "has no effect on how parser works" $ do-        let p = dbg "return" (return 'a')-            s = "abc"-        prs  p s `shouldParse` 'a'-        prs' p s `succeedsLeaving` s-      it "its hints are preserved" $ do-        let p = dbg "many chars" (many (char 'a')) <* empty-            s = "bcd"-        prs  p s `shouldFailWith` err posI (etok 'a')-        prs' p s `failsLeaving` "bcd"-    context "when inner parser fails without consuming" $-      it "has no effect on how parser works" $ do-        let p = dbg "empty" (void empty)-            s = "abc"-        prs  p s `shouldFailWith` err posI mempty-        prs' p s `failsLeaving` s--------------------------------------------------------------------------------- Helpers---- | This data type represents tokens in custom input stream.--data Span = Span-  { spanStart :: SourcePos-  , spanEnd   :: SourcePos-  , spanBody  :: NonEmpty Char-  } deriving (Eq, Ord, Show)--instance Stream [Span] where-  type Token [Span] = Span-  type Tokens [Span] = [Span]-  tokenToChunk Proxy = pure-  tokensToChunk Proxy = id-  chunkToTokens Proxy = id-  chunkLength Proxy = length-  chunkEmpty Proxy = null-  positionAt1 Proxy _ (Span start _ _) = start-  positionAtN Proxy pos [] = pos-  positionAtN Proxy _ (Span start _ _:_) = start-  advance1 Proxy _ _ (Span _ end _) = end-  advanceN Proxy _ pos [] = pos-  advanceN Proxy _ _ ts =-    let Span _ end _ = last ts in end-  take1_ [] = Nothing-  take1_ (t:ts) = Just (t, ts)-  takeN_ n s-    | n <= 0   = Just ([], s)-    | null s   = Nothing-    | otherwise = Just (splitAt n s)-  takeWhile_ = DL.span--instance Arbitrary Span where-  arbitrary = do-    start <- arbitrary-    end   <- arbitrary `suchThat` (> start)-    Span start end <$>-      (NE.fromList . getNonEmpty <$> arbitrary)--instance ShowToken Span where-  showTokens ts = concat (NE.toList . spanBody <$> ts)--instance ShowErrorComponent Int where-  showErrorComponent = show--type CustomParser = Parsec Void [Span]--pSpan :: Span -> CustomParser Span-pSpan span = token testToken (Just span)-  where-    f = Tokens . nes-    testToken x =-      if spanBody x == spanBody span-        then Right span-        else Left (pure (f x), E.singleton (f span))--incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])-incCoincidence st ts = do-  n <- getSmall <$> arbitrary-  let (pre, post) = splitAt n (stateInput st)-      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts-  return st { stateInput = pre' ++ post }--emulateStrParsing-  :: State String-  -> String-  -> (State String, Either (ParseError Char Void) String)-emulateStrParsing st@(State i (pos:|z) tp w) s =-  if s == take l i-    then ( State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w-         , Right s )-    else ( st-         , Left $ err (pos:|z) (etoks s <> utoks (take l i)) )-  where-    l = length s--eqParser :: (Eq a, Eq (Token i))-  => Parsec Void i a-  -> Parsec Void i a-  -> i -> Bool-eqParser p1 p2 i = runParser p1 "" i == runParser p2 "" i