packages feed

megaparsec 5.3.1 → 9.8.1

raw patch · 49 files changed

Files

− AUTHORS.md 
@@ -1,53 +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-* 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,570 @@+*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+  structures and data constructor of `ParsecT`.++## Megaparsec 6.4.1++* `scientific` now correctly backtracks after attempting to parse fractional+  and exponent parts of a number. `float` correctly backtracks after+  attempting to parse optional exponent part (when it comes after fractional+  part, otherwise it's obligatory).++## Megaparsec 6.4.0++* `Text.Megaparsec` now re-exports `Control.Monad.Combinators` instead of+  `Control.Applicative.Combinators` from `parser-combinators` because the+  monadic counterparts of the familiar combinators are more efficient and+  not as leaky.++  This may cause minor breakage in certain cases:++  * You import `Control.Applicative` and in that case there will be a name+    conflict between `Control.Applicative.many` and+    `Control.Monad.Combinator.many` now (the same for `some`).++  * You define a polymorphic helper in terms of combinator(s) from+    `Control.Applicative.Combinators` and use `Applicative` or `Alternative`+    constraint. In this case you'll have to adjust the constraint to be+    `Monad` or `MonadPlus` respectively.++  Also note that the new `Control.Monad.Combinators` module we re-export now+  re-exports `empty` from `Control.Applicative`.++* Fix the `atEnd` parser. It now does not produce hints, so when you use it,+  it won't contribute to the “expecting end of input” component of parse+  error.++## Megaparsec 6.3.0++* Added an `IsString` instance for `ParsecT`. Now it is possible to+  write `"abc"` rather than `string "abc"`.++* Added the `customFailure` combinator, which is a special case of+  `fancyFailure`.++* Made implementation of `sconcat` and `mconcat` of `ParsecT` more+  efficient.++## Megaparsec 6.2.0++* `float` in `Text.Megaparsec.Char.Lexer` and `Text.Megaparsec.Byte.Lexer`+  now does not accept plain integers. This is the behavior we had in version+  5 of the library.++## Megaparsec 6.1.1++* Fixed the bug when `tokens` used `cok` continuation even when matching an+  empty chunk. Now it correctly uses `eok` in this case.++## Megaparsec 6.1.0++* Improved rendering of offending line in `parseErrorPretty'` in the+  presence of tab characters.++* Added `parseErrorPretty_`, which is just like `parseErrorPretty'` but+  allows to specify tab width to use.++* Adjusted hint generation so when we backtrack a consuming parser with+  `try`, we do not create hints from its parse error (because it's further+  in input stream!). This was a quite subtle bug that stayed unnoticed for+  several years apparently.++## Megaparsec 6.0.2++* Allow `parser-combinators-0.2.0`.++## Megaparsec 6.0.1++* Fixed a typo in `README.md`.++* Added some text that clarifies how to parametrize the `ParseError` type.++## Megaparsec 6.0.0++### General++* Re-organized the module hierarchy. Some modules such as+  `Text.Megaparsec.Prim` do not exist anymore. Stream definitions were moved+  to `Text.Megaparsec.Stream`. Generic combinators are now re-exported from+  the `Control.Applicative.Combinators` from the package+  `parser-combinators`. Just import `Text.Megaparsec` and you should be OK.+  Add `Text.Megaparsec.Char` if you are working with a stream of `Char`s or+  `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.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.++* Dropped per-stream modules, the `Parser` type synonym is to be defined+  manually by user.++* Added a `MonadFix` instance for `ParsecT`.++* More lightweight dependency tree, dropped `exceptions` and `QuickCheck`+  dependencies.++* Added dependency on `case-insensitive`.++### Source positions++* Now `Pos` contains an `Int` inside, not `Word`.++* Dropped `unsafePos` and changed type of `mkPos` so it throws from pure+  code if its argument is not a positive `Int`.++* Added `pos1` constant that represents the `Pos` with value 1 inside.++* Made `InvalidPosException` contain the invalid `Int` value that was passed+  to `mkPos`.++### Parse errors++* Changed the definition of `ParseError` to have separate data constructors+  for “trivial” errors (unexpected/expected tokens) and “fancy” errors+  (everything else).++* Removed the `ErrorComponent` type class, added `ErrorFancy` instead.+  `ErrorFancy` is a sum type which can represent `fail` messages, incorrect+  indentation, and custom data (we use `Void` for that by default to+  “disable” it). This is better than the typeclass-based approach because+  every instance of `ErrorComponent` needed to have constructors for `fail`+  and indentation massages anyway, leading to duplication of code (for+  example for parse error component rendering).++* Added `Functor` instances for `ErrorItem` and `ErrorFancy`.++* Added the function `errorPos` to get error positions from `ParseError`+  (previously it was a record selector in `ParseError`).++* Control characters in parse error are displayed in a readable form even+  when they are part of strings, for example: `{<newline>` (`{` followed by+  the newline character). Previously control characters were rendered in+  readable form only as standalone tokens.++* Added `Text.Megaparsec.Error.Builder` module to help construct+  `ParseError`s easily. It is useful for testing and debugging. Previously+  we had something like that in the `hspec-megaparsec` package, but it does+  not hurt to ship it with the library.++* Added `parseErrorPretty'` allowing to display offending line in parse+  errors.++* Added `LineToken` type class for tokens that support operations necessary+  for selecting and displaying relevant line of input (used in+  `parseErrorPretty'`).++* Added `parseTest'` function that is just like `parseTest`, but also prints+  offending line in parse errors. This is powered by the new+  `parseErrorPretty'`.++### Stream++* Introduced the new `Text.Megaparsec.Stream` module that is the home of+  `Stream` type class. In version 6, the type class has been extended+  significantly to improve performance and make some combinators more+  general.++### Combinators++* Changed signatures of `failure` and `token`, they only can signal trivial+  errors now.++* Added a new method of `MonadParsec` type class called `fancyFailure` for+  signalling non-trivial failures. Signatures of some functions (`failure`,+  `token`) have been changed accordingly.++* Added `takeWhileP`, `takeWhile1P` and `takeP` to `MonadParsec`.++* Added `takeRest` non-primitive combinator to consume the rest of input.++* Added `atEnd` which returns `True` when end of input has been reached.++* Dropped `oneOf'` and `noneOf'` from `Text.Megaparsec.Char`. These were+  seldom (if ever) used and are easily re-implemented.++* Added `notChar` in `Text.Megaparsec.Char`.++* 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.Megaparsec.Char.Lexer`. Use `decimal`+  instead.++* `number` was dropped from `Text.Megaparsec.Char.Lexer`. Use `scientific`+  instead.++* `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return+  type and can be used to parse any instance of `Integral`.++* `float` is now polymorphic in its return type and can be used to parse any+  instance of `RealFloat`.++* Added new module `Text.Megaparsec.Byte.Lexer`, which provides some+  functions (white space and numeric helpers) from+  `Text.Megaparsec.Char.Lexer` for streams with token type `Word8`.+ ## Megaparsec 5.3.1  * Various updates to the docs.@@ -397,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–2017 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,16 +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)-[![Coverage Status](https://coveralls.io/repos/mrkkrp/megaparsec/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/megaparsec?branch=master)+[![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 and Happy support](#alex-and-happy-support)-    * [Character parsing](#character-parsing)-    * [Permutation parsing](#permutation-parsing)-    * [Expression parsing](#expression-parsing)+    * [External lexers](#external-lexers)+    * [Character and binary parsing](#character-and-binary-parsing)     * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials)@@ -23,205 +20,154 @@     * [Megaparsec vs Parsec](#megaparsec-vs-parsec)     * [Megaparsec vs Trifecta](#megaparsec-vs-trifecta)     * [Megaparsec vs Earley](#megaparsec-vs-earley)-    * [Megaparsec vs Parsers](#megaparsec-vs-parsers) * [Related packages](#related-packages)-* [Links to announcements](#links-to-announcements)-* [Authors](#authors)+* [Prominent projects that use Megaparsec](#prominent-projects-that-use-megaparsec)+* [Links to announcements and blog posts](#links-to-announcements-and-blog-posts) * [Contribution](#contribution) * [License](#license)  This is an industrial-strength monadic parser combinator library. Megaparsec-is a fork of [Parsec](https://github.com/aslatter/parsec) library originally-written by Daan Leijen.+is a feature-rich package that tries to find a nice balance between speed,+flexibility, and quality of parse errors.  ## Features -This project provides flexible solutions to satisfy common parsing needs.-The section describes them shortly. If you're looking for comprehensive+The project provides flexible solutions to satisfy common parsing needs. The+section describes them shortly. If you're looking for comprehensive documentation, see the [section about documentation](#documentation).  ### 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 monad-stack. Since the standard 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`. -The module-[`Text.Megaparsec.Combinator`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Combinator.html) (its-functions are included in `Text.Megaparsec`) contains traditional, general-combinators that work with instances of `Applicative` and `Alternative`.--Let's enumerate methods of the `MonadParsec` type class. The class abstracts-primitive functions of Megaparsec parsing. The rest of the library is built-via combination of these primitives:--* `failure` allows to fail reporting an arbitrary parse error.--* `label` allows to add a “label” to a parser, so if it fails the user will-  see the label instead of an automatically deduced expected token.--* `hidden` hides a parser from error messages altogether. This is the-  recommended way to hide things, prefer it to the `label ""` approach.--* `try` enables backtracking in parsing.--* `lookAhead` allows to parse input without consuming it.--* `notFollowedBy` succeeds when its argument fails and does not consume-  input.+Megaparsec includes all functionality that is typically available in+Parsec-like libraries and also features some special combinators: -* `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`).--* `eof` only succeeds at the end of input.--* `token` is used to parse a single token.--* `tokens` makes it easy to parse several tokens in a row.+* `observing` makes it possible to “observe” parse errors without ending+  parsing. -* `getParserState` returns the full parser state.+In addition to that, Megaparsec features high-performance combinators+similar to those found in [Attoparsec][attoparsec]: -* `updateParserState` applies a given function on the parser state.+* `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 repacking.+* `takeWhile` and `takeWhile1` are about 150 times faster than approaches+  involving `many`, `manyTill` and other similar combinators.+* `takeP` allows us to grab n tokens from the stream and returns them as a+  “chunk” of the stream. -This list of core functions is longer than in some other libraries. Our goal-is efficient, readable implementations, and rich functionality, not minimal-number of primitive combinators. You can read the comprehensive description-of every primitive function in-[Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html).+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 with great success.+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 introduces 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 anymore.+* Megaparsec has typed error messages and the ability to signal custom parse+  errors that better suit the user's domain of interest. -The default error component (`Dec`) has constructors corresponding to the-`fail` function and indentation-related error messages. It is a decent-option that should work out-of-box for most parsing needs, while you are-free to use your own custom error component when necessary.+* 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. -This new design allowed Megaparsec 5 to have much more helpful error-messages for indentation-sensitive parsing instead of the plain “incorrect-indentation” phrase.+* 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. -### Alex and Happy support+### External lexers -Megaparsec works well with streams of tokens produced by tools like-Alex/Happy. Megaparsec 5 adds `updatePos` method to `Stream` type class that-gives you full control over textual positions that are used to report token-positions in error messages. You can update current position on per-character basis or extract it from token.+Megaparsec works well with streams of tokens produced by tools like Alex.+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 parsing+### 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 (they all are included in `Text.Megaparsec`). The functions can be-divided into several categories:--* *Simple parsers*—parsers that parse certain character or several-  characters of the same kind. This includes `newline`, `crlf`, `eol`,-  `tab`, and `space`.--* *Parsers corresponding to categories of characters* parse single character-  that belongs to certain category of characters, for example:-  `controlChar`, `spaceChar`, `upperChar`, `lowerChar`, `printChar`,-  `digitChar`, and others.--* *General parsers* that allow you to parse a single character you specify-  or one of the given characters, or any character except for the given-  ones, or character satisfying given predicate. Case-insensitive versions-  of the parsers are available.--* *Parsers for sequences of characters* parse strings. Case-sensitive-  `string` parser is available as well as case-insensitive `string'`.--### 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.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-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`][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`. -`Text.Megaparsec.Lexer` is intended to be imported via 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 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. -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.+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. -Since Megaparsec 5, all tools for indentation-sensitive parsing are-available in `Text.Megaparsec.Lexer` module—no third party packages-required.+[`Text.Megaparsec.Byte.Lexer`][tm-byte-lexer] is also available for users+who wish to parse binary data.  ## Documentation -Megaparsec is well-documented. All functions and data-types are thoroughly-described. We pay attention to avoid outdated info or unclear phrases in our-documentation. See the [current version of Megaparsec documentation on-Hackage](https://hackage.haskell.org/package/megaparsec) for yourself.+Megaparsec is well-documented. See the [current version of 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 quite flexible, Megaparsec is also faster than Parsec. The-repository includes benchmarks that can be easily used to compare Megaparsec-and Parsec. In most cases Megaparsec is faster, sometimes dramatically-faster. If you happen to have some other benchmarks, I would appreciate if-you add Megaparsec to them and let me know how it performs.+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): -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).+Test case         | Execution time | Allocated | Max residency+------------------|---------------:|----------:|-------------:+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 +You can run the benchmarks yourself by executing:++```+$ 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,@@ -229,198 +175,178 @@  ### 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 much 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.+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 dense QuickCheck-  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. -* Some quirks and “buggy features” (as well as plain bugs) of original-  Parsec are fixed. There is no undocumented surprising stuff in Megaparsec.+* 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. -* Better support for Unicode parsing in `Text.Megaparsec.Char`.+* Some quirks and bugs of Parsec are fixed. +* Better support for Unicode parsing in [`Text.Megaparsec.Char`][tm-char].+ * Megaparsec has more powerful combinators and can parse languages where   indentation matters. -* Comprehensive QuickCheck test suite covering nearly 100% of our code.--* 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.--* 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 is faster.+* 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 ~~better~~ supported.+* 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. -To be honest Parsec's development has seemingly stagnated. It has no test-suite (only three per-bug tests), and all its releases beginning from-version 3.1.2 (according or its change log) were about introducing and-fixing regressions. Parsec is old and somewhat famous in the Haskell-community, so we understand there will be some kind of inertia, but we-advise you use Megaparsec from now on because it solves many problems of the-original Parsec project. If you think you still have a reason to use-original Parsec, open an issue.- ### Megaparsec vs Trifecta -[Trifecta](https://hackage.haskell.org/package/trifecta) is another Haskell-library featuring good error messages. Like some other projects of Edward-Kmett, it's probably good, but also under-documented, and has-unfixed [bugs and flaws](https://github.com/ekmett/trifecta/issues) that-Edward is too busy to fix (simply a fact, no offense intended). 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`, which is a very heavy dependency. If you're not into+  `lens`, you may not like the API. -* 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.+[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, chances 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.--### Megaparsec vs Parsers--There is [Parsers](https://hackage.haskell.org/package/parsers) package,-which is great. You can use it with Megaparsec or Parsec, but consider the-following:--* It depends on Attoparsec, Parsec, and Trifecta, which means you always-  grab half of Hackage as transitive dependencies by using it. This is-  ridiculous, by the way, because this package is supposed to be useful for-  parser builders, so they can write basic core functionality and get the-  rest “for free”.--* It currently has a ~~bug~~ feature in definition of `lookAhead` for-  various monad transformers like `StateT`, etc. which is visible when you-  create backtracking state via monad stack, not via built-in features. The-  feature makes it so `lookAhead` will backtrack your parser state but not-  your custom state added via `StateT`. Kmett thinks this behavior is-  better.--We intended to use Parsers library in Megaparsec at some point, but aside-from already mentioned flaws the library has different conventions for-naming of things, different set of “core” functions, etc., different-approach to lexing. So it didn't happen, Megaparsec has minimal-dependencies, it is feature-rich and self-contained.+In other words, Megaparsec is less safe but also more powerful.  ## Related packages -The following packages are designed to be used with Megaparsec:+The following packages are designed to be used with Megaparsec (open a PR if+you want to add something to the list):  * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities-  for testing Megaparsec parsers with-  with [Hspec](https://hackage.haskell.org/package/hspec).-+  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).-+  parser of CSV files that plays nicely with+  [Cassava](https://hackage.haskell.org/package/cassava). * [`tagsoup-megaparsec`](https://hackage.haskell.org/package/tagsoup-megaparsec)—a-  library for easily-  using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token-  type in Megaparsec.+  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. -## Links to announcements+## 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++## 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–2017 Megaparsec contributors<br>-Copyright © 2007 Paolo Martini<br>+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–2017 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -11,207 +20,645 @@ -- -- 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>.------ By default this module is set up to parse character data. If you'd like--- to parse the result of your own tokenizer you should start with the--- following imports:+-- at the tutorial <https://markkarpov.com/tutorial/megaparsec.html>. ----- > import Text.Megaparsec.Prim--- > import Text.Megaparsec.Combinator+-- In addition to the "Text.Megaparsec" module, which exports and re-exports+-- 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. ----- Then you can implement your own version of 'satisfy' on top of the--- 'token' primitive, etc.+-- It is common to start working with the library by defining a type synonym+-- like this: ----- The typical import section looks like this:+-- > type Parser = Parsec Void Text+-- >                      ^    ^+-- >                      |    |+-- > Custom error component    Input stream type ----- > import Text.Megaparsec--- > import Text.Megaparsec.String--- > -- import Text.Megaparsec.ByteString--- > -- import Text.Megaparsec.ByteString.Lazy--- > -- import Text.Megaparsec.Text--- > -- import Text.Megaparsec.Text.Lazy+-- Then you can write type signatures like @Parser 'Int'@—for a parser that+-- returns an 'Int' for example. ----- As you can see the second import depends on the data type you want to use--- as input stream. It just defines the useful type-synonym @Parser@.+-- Similarly (since it's known to cause confusion), you should use+-- 'ParseErrorBundle' type parametrized like this: ----- Megaparsec 5 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 like “Ambiguous type variable @e0@ arising from … prevents the--- constraint @(ErrorComponent e0)@ from being resolved”, 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.+-- > ParseErrorBundle Text Void+-- >                  ^    ^+-- >                  |    |+-- >  Input stream type    Custom error component (the same you used in Parser) ----- 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", and even entire languages with--- "Text.Megaparsec.Lexer". These modules should be imported explicitly--- along with the two modules mentioned above.-+-- 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 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. module Text.Megaparsec-  ( -- * Running parser-    Parsec-  , ParsecT-  , parse-  , parseMaybe-  , parseTest-  , runParser-  , runParser'-  , runParserT-  , runParserT'-    -- * Combinators-  , (A.<|>)-  -- $assocbo-  , A.many-  -- $many-  , A.some-  -- $some-  , A.optional-  -- $optional-  , unexpected-  , match-  , region-  , failure-  , (<?>)-  , label-  , hidden-  , try-  , lookAhead-  , notFollowedBy-  , withRecovery-  , observing-  , eof-  , token-  , tokens-  , between-  , choice-  , count-  , count'-  , eitherP-  , endBy-  , endBy1-  , manyTill-  , someTill-  , option-  , sepBy-  , sepBy1-  , sepEndBy-  , sepEndBy1-  , skipMany-  , skipSome-    -- * Character parsing-  , newline-  , crlf-  , eol-  , tab-  , space-  , controlChar-  , spaceChar-  , upperChar-  , lowerChar-  , letterChar-  , alphaNumChar-  , printChar-  , digitChar-  , octDigitChar-  , hexDigitChar-  , markChar-  , numberChar-  , punctuationChar-  , symbolChar-  , separatorChar-  , asciiChar-  , latin1Char-  , charCategory-  , char-  , char'-  , anyChar-  , oneOf-  , oneOf'-  , noneOf-  , noneOf'-  , satisfy-  , string-  , string'-    -- * Textual source position-  , Pos-  , mkPos-  , unPos-  , unsafePos-  , InvalidPosException (..)-  , SourcePos (..)-  , initialPos-  , sourcePosPretty-    -- * Error messages-  , ErrorItem (..)-  , ErrorComponent (..)-  , Dec (..)-  , ParseError (..)-  , ShowToken (..)-  , ShowErrorComponent (..)-  , parseErrorPretty-    -- * Debugging-  , dbg-    -- * Low-level operations-  , Stream (..)-  , State (..)-  , getInput-  , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , getParserState-  , setParserState-  , updateParserState )-where+  ( -- * Re-exports+    -- $reexports+    module Text.Megaparsec.Pos,+    module Text.Megaparsec.Error,+    module Text.Megaparsec.Stream,+    module Control.Monad.Combinators, -import qualified Control.Applicative as A+    -- * Data types+    State (..),+    PosState (..),+    Parsec,+    ParsecT, -import Text.Megaparsec.Char-import Text.Megaparsec.Combinator+    -- * Running parser+    parse,+    parseMaybe,+    parseTest,+    runParser,+    runParser',+    runParserT,+    runParserT',++    -- * Primitive combinators+    MonadParsec (..),++    -- * Signaling parse errors+    -- $parse-errors+    failure,+    fancyFailure,+    unexpected,+    customFailure,+    region,+    registerParseError,+    registerFailure,+    registerFancyFailure,++    -- * Derivatives of primitive combinators+    single,+    satisfy,+    anySingle,+    anySingleBut,+    oneOf,+    noneOf,+    chunk,+    (<?>),+    match,+    takeRest,+    atEnd,++    -- * Parser state combinators+    getInput,+    setInput,+    getSourcePos,+    getOffset,+    setOffset,+    setParserState,+  )+where++import Control.Monad.Combinators+import Control.Monad.Identity+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromJust)+import Data.Set (Set)+import qualified Data.Set as E+import Text.Megaparsec.Class import Text.Megaparsec.Error+import Text.Megaparsec.Internal import Text.Megaparsec.Pos-import Text.Megaparsec.Prim+import Text.Megaparsec.State+import Text.Megaparsec.Stream --- $assocbo+-- $reexports ----- This combinator implements choice. The parser @p \<|> q@ first applies--- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails--- /without consuming any input/, parser @q@ is tried.+-- 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+-- functions from "Control.Applicative". You need to hide the functions like+-- this: ----- The parser is called /predictive/ since @q@ is only tried when parser @p@--- didn't consume any input (i.e. the look ahead is 1). This--- non-backtracking behaviour allows for both an efficient implementation of--- the parser combinators and the generation of good error messages.+-- > 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+-- /0.4.0/).+--+-- 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. --- $many+----------------------------------------------------------------------------+-- 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+-- '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. ----- @many p@ applies the parser @p@ /zero/ or more times and returns a list--- of the returned values of @p@. Note that if the @p@ parser fails--- consuming input, then the entire @many p@ parser fails with the error--- message @p@ produced instead of just stopping iterating. In these cases--- wrapping @p@ with 'try' may be desirable.+-- > main = case parse numbers "" "11,2,43" of+-- >          Left bundle -> putStr (errorBundlePretty bundle)+-- >          Right xs -> print (sum xs)+-- >+-- > numbers = decimal `sepBy` char ',' ----- > identifier = (:) <$> letter <*> many (alphaNumChar <|> 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 --- $some+-- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the+-- result inside 'Just' on success and 'Nothing' on failure. This function+-- also parses 'eof', so if the parser doesn't consume all of its input, it+-- will fail. ----- @some p@ applies the parser @p@ /one/ or more times and returns a list of--- the returned values of @p@. The note about behavior of the combinator in--- the case when @p@ fails consuming input (see 'A.many') applies to 'some'--- as well.+-- The function is supposed to be useful for lightweight parsing, where+-- error messages (and thus file names) are not important and entire input+-- should be 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+    Right x -> Just x++-- | The expression @'parseTest' p input@ applies the parser @p@ on the+-- input @input@ and prints the result to stdout. Useful for testing.+parseTest ::+  ( ShowErrorComponent e,+    Show a,+    VisualStream s,+    TraversableStream s+  ) =>+  -- | Parser to run+  Parsec e s a ->+  -- | Input for parser+  s ->+  IO ()+parseTest p input =+  case parse p "" input of+    Left e -> putStr (errorBundlePretty e)+    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+-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). ----- > word = some letter+-- > parseFromFile p file = runParser p file <$> readFile file+--+-- '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) --- $optional+-- | The function is similar to 'runParser' with the difference that it+-- 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. ----- @optional p@ tries to apply the parser @p@. It will parse @p@ or nothing.--- It only fails if @p@ fails after consuming input. On success result of--- @p@ is returned inside of 'Just', on failure 'Nothing' is returned.+-- @since 4.2.0+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 '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) =>+  -- | Parser to run+  ParsecT e s m a ->+  -- | Initial state+  State s e ->+  m (State s e, Either (ParseErrorBundle s e) a)+runParserT' p s = do+  (Reply s' _ result) <- runParsecT p s+  let toBundle es =+        ParseErrorBundle+          { bundleErrors =+              NE.sortWith errorOffset es,+            bundlePosState = statePosState s+          }+  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')))++----------------------------------------------------------------------------+-- Signaling parse errors++-- $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.++-- | 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 #-}++-- | 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 (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 = fancyFailure . E.singleton . ErrorCustom+{-# INLINE customFailure #-}++-- | Specify how to process 'ParseError's that happen inside of this+-- 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) =>+  -- | 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 -> parseError (f err)+    Right x -> return x+{-# INLINEABLE region #-}++-- | 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 8.0.0+registerParseError :: (MonadParsec e s m) => ParseError s e -> m ()+registerParseError e = updateParserState $ \s ->+  s {stateParseErrors = e : stateParseErrors s}+{-# INLINE registerParseError #-}++-- | Like 'failure', but for delayed 'ParseError's.+--+-- @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 #-}++-- | 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 #-}++----------------------------------------------------------------------------+-- Derivatives of primitive combinators++-- | @'single' t@ only matches the single token @t@.+--+-- > semicolon = single ';'+--+-- See also: 'token', 'anySingle', 'Text.Megaparsec.Byte.char',+-- 'Text.Megaparsec.Char.char'.+--+-- @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 #-}++-- | The parser @'satisfy' f@ succeeds for any token for which the supplied+-- function @f@ returns 'True'.+--+-- > digitChar = satisfy isDigit <?> "digit"+-- > oneOf cs  = satisfy (`elem` cs)+--+-- __Performance note__: when you need to parse a single token, it is often+-- a good idea to use 'satisfy' with the right predicate function instead of+-- creating a complex parser using the combinators.+--+-- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'.+--+-- @since 7.0.0+satisfy ::+  (MonadParsec e s m) =>+  -- | 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 #-}++-- | Parse and return a single token. It's a good idea to attach a 'label'+-- to this parser.+--+-- > anySingle = satisfy (const True)+--+-- See also: 'satisfy', 'anySingleBut'.+--+-- @since 7.0.0+anySingle :: (MonadParsec e s m) => m (Token s)+anySingle = satisfy (const True)+{-# INLINE anySingle #-}++-- | 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 #-}++-- | @'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 #-}++-- | 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 ('<?>').+--+-- > noneOf cs = satisfy (`notElem` cs)+--+-- See also: 'satisfy'.+--+-- __Performance note__: prefer 'satisfy' and 'anySingleBut' when you can+-- because it's faster.+--+-- @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@.+--+-- > 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 #-}++-- | A synonym for 'label' in the form of an operator.+infix 0 <?>++(<?>) :: (MonadParsec e s m) => m a -> String -> m a+(<?>) = flip label+{-# INLINE (<?>) #-}++-- | 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 #-}++-- | 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 #-}++-- | 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 #-}++----------------------------------------------------------------------------+-- Parser state combinators++-- | Return the current input.+getInput :: (MonadParsec e s m) => m s+getInput = stateInput <$> getParserState+{-# INLINE getInput #-}++-- | @'setInput' input@ continues parsing with @input@.+setInput :: (MonadParsec e s m) => s -> m ()+setInput s = updateParserState (\(State _ o pst de) -> State s o pst de)+{-# INLINE setInput #-}++-- | 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 #-}++-- | 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 #-}++-- | 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
@@ -0,0 +1,264 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :  Text.Megaparsec.Byte+-- Copyright   :  © 2015–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Commonly used binary parsers.+--+-- @since 6.0.0+module Text.Megaparsec.Byte+  ( -- * Simple parsers+    newline,+    crlf,+    eol,+    tab,+    space,+    hspace,+    space1,+    hspace1,++    -- * Categories of characters+    controlChar,+    spaceChar,+    upperChar,+    lowerChar,+    letterChar,+    alphaNumChar,+    printChar,+    digitChar,+    binDigitChar,+    octDigitChar,+    hexDigitChar,+    asciiChar,++    -- * Single byte+    char,+    char',++    -- * Sequence of bytes+    string,+    string',+  )+where++import Control.Applicative+import Data.Char hiding (isSpace, toLower, toUpper)+import Data.Functor (void)+import Data.Proxy+import Data.Word (Word8)+import Text.Megaparsec+import Text.Megaparsec.Common++----------------------------------------------------------------------------+-- Simple parsers++-- | Parse a newline byte.+newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+newline = char 10+{-# INLINE newline #-}++-- | Parse a carriage return character followed by a newline character.+-- Return the sequence of characters parsed.+crlf :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s)+crlf = string (tokensToChunk (Proxy :: Proxy s) [13, 10])+{-# 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"+{-# INLINE eol #-}++-- | Parse a tab character.+tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+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+{-# 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+{-# INLINE space1 #-}++-- | Like 'space1', but does not accept newlines and carriage returns.+--+-- @since 9.0.0+hspace1 :: (MonadParsec e s m, Token s ~ Word8) => m ()+hspace1 = void $ takeWhile1P (Just "white space") isHSpace+{-# INLINE hspace1 #-}++----------------------------------------------------------------------------+-- Categories of characters++-- | Parse a control character.+controlChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+controlChar = satisfy (isControl . toChar) <?> "control character"+{-# INLINE controlChar #-}++-- | Parse a space character, and the control characters: tab, newline,+-- carriage return, form feed, and vertical tab.+spaceChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+spaceChar = satisfy isSpace <?> "white space"+{-# INLINE spaceChar #-}++-- | Parse an upper-case character.+upperChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+upperChar = satisfy (isUpper . toChar) <?> "uppercase letter"+{-# INLINE upperChar #-}++-- | Parse a lower-case alphabetic character.+lowerChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+lowerChar = satisfy (isLower . toChar) <?> "lowercase letter"+{-# INLINE lowerChar #-}++-- | Parse an alphabetic character: lower-case or upper-case.+letterChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+letterChar = satisfy (isLetter . toChar) <?> "letter"+{-# INLINE letterChar #-}++-- | Parse an alphabetic or digit characters.+alphaNumChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+alphaNumChar = satisfy (isAlphaNum . toChar) <?> "alphanumeric character"+{-# INLINE alphaNumChar #-}++-- | Parse a printable character: letter, number, mark, punctuation, symbol+-- or space.+printChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+printChar = satisfy (isPrint . toChar) <?> "printable character"+{-# INLINE printChar #-}++-- | Parse an ASCII digit, i.e between “0” and “9”.+digitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+digitChar = satisfy isDigit' <?> "digit"+  where+    isDigit' x = x >= 48 && x <= 57+{-# INLINE digitChar #-}++-- | 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 = 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 = satisfy (isHexDigit . toChar) <?> "hexadecimal digit"+{-# INLINE hexDigitChar #-}++-- | Parse a character from the first 128 characters of the Unicode+-- character set, corresponding to the ASCII character set.+asciiChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+asciiChar = satisfy (< 128) <?> "ASCII character"+{-# INLINE asciiChar #-}++----------------------------------------------------------------------------+-- 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.+--+-- >>> parseTest (char' 101) "E"+-- 69 -- 'E'+-- >>> parseTest (char' 101) "G"+-- 1:1:+-- unexpected 'G'+-- expecting 'E' or 'e'+char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s)+char' c =+  choice+    [ char (toLower c),+      char (toUpper c)+    ]+{-# INLINE char' #-}++----------------------------------------------------------------------------+-- Helpers++-- | '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 #-}++-- | Like 'isSpace', but does not accept newlines and carriage returns.+isHSpace :: Word8 -> Bool+isHSpace x+  | x == 9 = True+  | x == 11 = True+  | x == 12 = True+  | x == 32 = True+  | x == 160 = True+  | otherwise = False+{-# INLINE isHSpace #-}++-- | Convert a byte to char.+toChar :: Word8 -> Char+toChar = chr . fromIntegral+{-# INLINE toChar #-}++-- | Convert a byte to its upper-case version.+toUpper :: Word8 -> Word8+toUpper x+  | x >= 97 && x <= 122 = x - 32+  | x == 247 = x -- division sign+  | x == 255 = x -- latin small letter y with diaeresis+  | x >= 224 = x - 32+  | otherwise = x+{-# INLINE toUpper #-}++-- | 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
@@ -0,0 +1,306 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :  Text.Megaparsec.Byte.Lexer+-- Copyright   :  © 2015–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Stripped-down version of "Text.Megaparsec.Char.Lexer" for streams of+-- bytes.+--+-- This module is intended to be imported qualified:+--+-- > import qualified Text.Megaparsec.Byte.Lexer as L+module Text.Megaparsec.Byte.Lexer+  ( -- * White space+    space,+    lexeme,+    symbol,+    symbol',+    skipLineComment,+    skipBlockComment,+    skipBlockCommentNested,++    -- * Numbers+    decimal,+    binary,+    octal,+    hexadecimal,+    scientific,+    float,+    signed,+  )+where++import Control.Applicative+import Data.Functor (void)+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 qualified Text.Megaparsec.Byte as B+import Text.Megaparsec.Lexer++----------------------------------------------------------------------------+-- White space++-- | 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) =>+  -- | Line comment prefix+  Tokens s ->+  m ()+skipLineComment prefix =+  B.string prefix *> void (takeWhileP (Just "character") (/= 10))+{-# INLINEABLE skipLineComment #-}++-- | @'skipBlockComment' start end@ skips non-nested block comment starting+-- with @start@ and ending with @end@.+skipBlockComment ::+  (MonadParsec e s m) =>+  -- | Start of block comment+  Tokens s ->+  -- | End of block comment+  Tokens s ->+  m ()+skipBlockComment start end = p >> void (manyTill anySingle n)+  where+    p = B.string start+    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) =>+  -- | Start of block comment+  Tokens s ->+  -- | End of block comment+  Tokens s ->+  m ()+skipBlockCommentNested start end = p >> void (manyTill e n)+  where+    e = skipBlockCommentNested start end <|> void anySingle+    p = B.string start+    n = B.string end+{-# INLINEABLE skipBlockCommentNested #-}++----------------------------------------------------------------------------+-- Numbers++-- | Parse an integer in the decimal representation according to the format+-- of integer literals described in the Haskell report.+--+-- If you need to parse signed integers, see the 'signed' combinator.+--+-- __Warning__: this function does not perform range checks.+decimal ::+  forall e s m a.+  (MonadParsec e s m, Token s ~ Word8, Num a) =>+  m a+decimal = decimal_ <?> "integer"+{-# INLINEABLE decimal #-}++-- | A non-public helper to parse decimal integers.+decimal_ ::+  forall e s m a.+  (MonadParsec e s m, Token s ~ Word8, Num a) =>+  m a+decimal_ = mkNum <$> takeWhile1P (Just "digit") isDigit+  where+    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 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+-- the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > 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 = 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 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+-- parsing the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > 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 = 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)+    isHexDigit w =+      (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+-- great for parsing of arbitrary precision numbers coming from an untrusted+-- source. See documentation in "Data.Scientific" for more information.+--+-- The parser can be used to parse integers or floating point values. Use+-- functions like 'Data.Scientific.floatingOrInteger' from "Data.Scientific"+-- to test and extract integer or real values.+--+-- 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 = do+  c' <- decimal_+  SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c')+  e <- option e' (try $ exponent_ e')+  return (Sci.scientific c e)+{-# INLINEABLE scientific #-}++data SP = SP !Integer {-# UNPACK #-} !Int++-- | Parse a floating point number according to the syntax for floating+-- point literals described in the Haskell report.+--+-- 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.+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)+        )+{-# INLINEABLE float #-}++dotDecimal_ ::+  (MonadParsec e s m, Token s ~ Word8) =>+  Proxy s ->+  Integer ->+  m SP+dotDecimal_ pxy c' = do+  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_ e' = do+  void (B.char' 101)+  (+ 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+-- character.+--+-- For example, to parse signed integer you can write:+--+-- > lexeme        = L.lexeme spaceConsumer+-- > integer       = lexeme L.decimal+-- > signedInteger = L.signed spaceConsumer integer+signed ::+  (MonadParsec e s m, Token s ~ Word8, Num a) =>+  -- | How to consume white space after the sign+  m () ->+  -- | How to parse the number itself+  m a ->+  -- | Parser for signed numbers+  m a+signed spc p = option id (lexeme spc sign) <*> p+  where+    sign = (id <$ B.char 43) <|> (negate <$ B.char 45)+{-# INLINEABLE signed #-}++----------------------------------------------------------------------------+-- Helpers++-- | 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/ByteString.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with strict 'ByteString'.--module Text.Megaparsec.ByteString (Parser) where--import Data.ByteString-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for strict--- 'ByteString's.--type Parser = Parsec Dec ByteString
− Text/Megaparsec/ByteString/Lazy.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString.Lazy--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with lazy 'ByteString'.--module Text.Megaparsec.ByteString.Lazy (Parser) where--import Data.ByteString.Lazy-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change the type of input--- stream by importing different “type modules”. This one is for lazy--- 'ByteString's.--type Parser = Parsec Dec ByteString
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–2017 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD@@ -10,141 +17,144 @@ -- Portability :  non-portable -- -- Commonly used character parsers.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}- module Text.Megaparsec.Char   ( -- * Simple parsers-    newline-  , crlf-  , eol-  , tab-  , space+    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-  , oneOf-  , oneOf'-  , noneOf-  , 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.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromJust)-import qualified Data.Set as E--import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Prim--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (), any, elem, notElem)-import Prelude hiding (any, elem, notElem)-#endif+import Data.Functor (void)+import Data.Proxy+import Text.Megaparsec+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- Simple parsers  -- | Parse a newline character.--newline :: (MonadParsec e s m, Token s ~ Char) => m Char+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 :: (MonadParsec e s m, Token s ~ Char) => m String-crlf = string "\r\n"+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 = (pure <$> newline) <|> crlf <?> "end of line"--eol :: (MonadParsec e s m, Token s ~ Char) => m String-eol = (pure <$> newline) <|> crlf <?> "end of line"+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" {-# INLINE eol #-}  -- | Parse a tab character.--tab :: (MonadParsec e s m, Token s ~ Char) => m Char+tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-}  -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'.- space :: (MonadParsec e s m, Token s ~ Char) => m ()-space = skipMany spaceChar+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 Char+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 Char+spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace <?> "white space" {-# INLINE spaceChar #-}  -- | 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 Char+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 Char+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 Char+letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter <?> "letter" {-# INLINE letterChar #-} @@ -153,143 +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 Char+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 Char+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 Char+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 #-} -octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | 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 Char+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 Char+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 Char+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 Char+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 Char+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 Char+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 Char+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 Char+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 Char+-- | @'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 cat = satisfy ((== cat) . generalCategory) <?> categoryName cat {-# INLINE charCategory #-}  -- | Return the human-readable name of Unicode General Category.- categoryName :: GeneralCategory -> String-categoryName cat =-  fromJust $ lookup cat-  [ (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")-  , (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") ]+categoryName = \case+  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"+  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"  ------------------------------------------------------------------------------- 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 ~ Char) => Char -> m Char-char c = token testChar (Just c)-  where-    f x = E.singleton (Tokens (x:|[]))-    testChar x =-      if x == c-        then Right x-        else Left (f x, f c, E.empty)+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@@ -301,116 +301,18 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e'--char' :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char-char' c = choice [char c, char $ swapCase c]-  where-    swapCase x-      | isUpper x = toLower x-      | isLower x = toUpper x-      | otherwise = x+char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s)+char' c =+  choice+    [ char (toLower c),+      char (toUpper c),+      char (toTitle c)+    ] {-# INLINE char' #-} --- | This parser succeeds for any character. Returns the parsed character.--anyChar :: (MonadParsec e s m, Token s ~ Char) => m Char-anyChar = satisfy (const True) <?> "character"-{-# INLINE anyChar #-}---- | @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"--oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-oneOf cs = satisfy (`elem` cs)-{-# INLINE oneOf #-}---- | The same as 'oneOf', but case-insensitive. Returns the parsed character--- preserving its case.------ > vowel = oneOf' "aeiou" <?> "vowel"--oneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-oneOf' cs = satisfy (`elemi` 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.--noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-noneOf cs = satisfy (`notElem` cs)-{-# INLINE noneOf #-}---- | The same as 'noneOf', but case-insensitive.------ > consonant = noneOf' "aeiou" <?> "consonant"--noneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-noneOf' cs = satisfy (`notElemi` 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 ~ Char) => (Char -> Bool) -> m Char-satisfy f = token testChar Nothing-  where-    testChar x =-      if f x-        then Right x-        else Left (E.singleton (Tokens (x:|[])), E.empty, 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, Token s ~ Char) => String -> m String-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"--string' :: (MonadParsec e s m, Token s ~ Char) => String -> m String-string' = tokens casei-{-# INLINE string' #-}------------------------------------------------------------------------------ -- Helpers --- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toUpper x == toUpper y-{-# INLINE casei #-}---- | Case-insensitive 'elem'.--elemi :: Foldable f => Char -> f Char -> Bool-elemi = any . casei-{-# INLINE elemi #-}---- | Case-insensitive 'notElem'.--notElemi :: Foldable f => Char -> f Char -> Bool-notElemi c = not . elemi c-{-# INLINE notElemi #-}+-- | Is it a horizontal space character?+isHSpace :: Char -> Bool+isHSpace x = isSpace x && x /= '\n' && x /= '\r'
+ Text/Megaparsec/Char/Lexer.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :  Text.Megaparsec.Char.Lexer+-- Copyright   :  © 2015–present Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- 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.+--+-- Parsing of white space is an important part of any parser. We propose a+-- convention where __every lexeme parser assumes no spaces before the__+-- __lexeme and consumes all spaces after the lexeme__; this is what the+-- 'lexeme' combinator does, and so it's enough to wrap every lexeme parser+-- with 'lexeme' to achieve this. Note that you'll need to call 'space'+-- manually to consume any white space before the first lexeme (i.e. at the+-- beginning of the file).+--+-- This module is intended to be imported qualified:+--+-- > import qualified Text.Megaparsec.Char.Lexer as L+--+-- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer".+module Text.Megaparsec.Char.Lexer+  ( -- * White space+    space,+    lexeme,+    symbol,+    symbol',+    skipLineComment,+    skipBlockComment,+    skipBlockCommentNested,++    -- * Indentation+    indentLevel,+    incorrectIndent,+    indentGuard,+    nonIndented,+    IndentOpt (..),+    indentBlock,+    lineFold,++    -- * Character and string literals+    charLiteral,++    -- * Numbers+    decimal,+    binary,+    octal,+    hexadecimal,+    scientific,+    float,+    signed,+  )+where++import Control.Applicative+import Control.Monad (void)+import qualified Data.Char as Char+import qualified Data.List+import Data.List.NonEmpty (NonEmpty (..))+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 Text.Megaparsec.Char as C+import Text.Megaparsec.Lexer++----------------------------------------------------------------------------+-- White space++-- | 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) =>+  -- | 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) =>+  -- | 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+{-# 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 ~ Char) =>+  -- | Start of block comment+  Tokens s ->+  -- | End of block comment+  Tokens s ->+  m ()+skipBlockCommentNested start end = p >> void (manyTill e n)+  where+    e = skipBlockCommentNested start end <|> void anySingle+    p = C.string start+    n = C.string end+{-# INLINEABLE skipBlockCommentNested #-}++----------------------------------------------------------------------------+-- Indentation++-- | Return the current indentation level.+--+-- The function is a simple shortcut defined as:+--+-- > indentLevel = sourceColumn <$> getPosition+--+-- @since 4.3.0+indentLevel :: (TraversableStream s, MonadParsec e s m) => m Pos+indentLevel = sourceColumn <$> getSourcePos+{-# INLINE indentLevel #-}++-- | Fail reporting incorrect indentation error. The error has attached+-- information:+--+--     * Desired ordering between reference level and actual level+--     * Reference indentation level+--     * Actual indentation level+--+-- @since 5.0.0+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+-- (indentation) with @spaceConsumer@ parser, then it checks the column+-- position. Ordering between current indentation level and the reference+-- indentation level @ref@ should be @ord@, otherwise the parser fails. On+-- success the current column position is returned.+--+-- When you want to parse a block of indentation, first run this parser with+-- 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 ::+  (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+  if compare actual ref == ord+    then return actual+    else incorrectIndent ord ref actual+{-# INLINEABLE indentGuard #-}++-- | Parse a non-indented construction. This ensures that there is no+-- indentation before actual data. Useful, for example, as a wrapper for+-- top-level function definitions.+--+-- @since 4.3.0+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 #-}++-- | Behaviors for parsing of indented tokens. This is used in+-- 'indentBlock', which see.+--+-- @since 4.3.0+data IndentOpt m a b+  = -- | 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+    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 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.+--+-- __Note__: the first argument of this function /must/ consume newlines+-- among other white space characters.+--+-- @since 4.3.0+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+  case a of+    IndentNone x -> x <$ sc+    IndentMany indent f p -> do+      mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)+      done <- isJust <$> optional eof+      case (mlvl, done) of+        (Just lvl, False) ->+          indentedItems ref (fromMaybe lvl indent) sc p >>= f+        _ -> sc *> f []+    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)+{-# INLINEABLE indentBlock #-}++-- | Grab indented items. This is a helper for 'indentBlock', it's not a+-- part of the public API.+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+      done <- isJust <$> optional eof+      if done+        then return []+        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 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:+--+-- > sc = L.space (void spaceChar) empty empty+-- >+-- > myFold = L.lineFold sc $ \sc' -> do+-- >   L.symbol sc' "foo"+-- >   L.symbol sc' "bar"+-- >   L.symbol sc  "baz" -- for the last symbol we use normal space consumer+--+-- @since 5.0.0+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 #-}++----------------------------------------------------------------------------+-- Character and string literals++-- | The lexeme parser parses a single literal character without quotes. The+-- purpose of this parser is to help with parsing of conventional escape+-- sequences. It's your responsibility to take care of character literal+-- syntax in your language (by surrounding it with single quotes or+-- similar).+--+-- The literal character is parsed according to the grammar rules defined in+-- the Haskell report.+--+-- Note that you can use this parser as a building block to parse various+-- string literals:+--+-- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"')+--+-- __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 10 anySingle)+  case listToMaybe (Char.readLitChar r) of+    Just (c, r') -> c <$ skipCount (length r - length r') anySingle+    Nothing -> unexpected (Tokens (head r :| []))+{-# INLINEABLE charLiteral #-}++----------------------------------------------------------------------------+-- Numbers++-- | Parse an integer in the decimal representation according to the format+-- of integer literals described in the Haskell report.+--+-- If you need to parse signed integers, see the 'signed' combinator.+--+-- __Note__: before the version /6.0.0/ the function returned 'Integer',+-- i.e. it wasn't polymorphic in its return type.+--+-- __Warning__: this function does not perform range checks.+decimal :: (MonadParsec e s m, Token s ~ Char, Num a) => m a+decimal = decimal_ <?> "integer"+{-# INLINEABLE decimal #-}++-- | A non-public helper to parse decimal integers.+decimal_ ::+  forall e s m a.+  (MonadParsec e s m, Token s ~ Char, Num a) =>+  m a+decimal_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit+  where+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a c = a * 10 + fromIntegral (Char.digitToInt c)+{-# INLINE decimal_ #-}++-- | Parse an integer in binary representation. 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+-- the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > octal = char '0' >> char' 'o' >> L.octal+--+-- __Note__: before 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.+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 = 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 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+-- parsing the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal+--+-- __Note__: before 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.+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 = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a c = a * 16 + fromIntegral (Char.digitToInt c)+{-# INLINEABLE hexadecimal #-}++-- | Parse a floating point value as a 'Scientific' number. 'Scientific' is+-- great for parsing of arbitrary precision numbers coming from an untrusted+-- source. See documentation in "Data.Scientific" for more information.+--+-- The parser can be used to parse integers or floating point values. Use+-- functions like 'Data.Scientific.floatingOrInteger' from "Data.Scientific"+-- to test and extract integer or real values.+--+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.+--+-- @since 5.0.0+scientific ::+  forall e s m.+  (MonadParsec e s m, Token s ~ Char) =>+  m Scientific+scientific = do+  c' <- decimal_+  SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c')+  e <- option e' (try $ exponent_ e')+  return (Sci.scientific c e)+{-# INLINEABLE scientific #-}++data SP = SP !Integer {-# UNPACK #-} !Int++-- | Parse a floating point number according to the syntax for floating+-- point literals described in the Haskell report.+--+-- 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+-- wasn't polymorphic in its return type.+--+-- __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)+        )+{-# INLINEABLE float #-}++dotDecimal_ ::+  (MonadParsec e s m, Token s ~ Char) =>+  Proxy s ->+  Integer ->+  m SP+dotDecimal_ pxy c' = do+  void (C.char '.')+  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_ e' = do+  void (C.char' 'e')+  (+ e') <$> signed (return ()) decimal_+{-# INLINE exponent_ #-}++-- | @'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:+--+-- > lexeme        = L.lexeme spaceConsumer+-- > integer       = lexeme L.decimal+-- > signedInteger = L.signed spaceConsumer integer+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 '-')+{-# INLINEABLE signed #-}
+ Text/Megaparsec/Class.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :  Text.Megaparsec.Class+-- Copyright   :  © 2015–present Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Definition of 'MonadParsec'—type class describing monads that implement+-- the full set of primitive parsers.+--+-- @since 6.5.0+module Text.Megaparsec.Class+  ( MonadParsec (..),+  )+where++import Control.Monad+import Control.Monad.Identity+import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S+import Control.Monad.Trans+import qualified Control.Monad.Trans.Reader as L+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.Strict as S+import Data.Set (Set)+import Text.Megaparsec.Error+import {-# SOURCE #-} Text.Megaparsec.Internal (Reply)+import Text.Megaparsec.State+import Text.Megaparsec.Stream++-- | Type class describing monads that implement the full set of primitive+-- parsers.+--+-- __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 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 the parser @p@, except that it+  -- backtracks the parser state when @p@ fails (either consuming input or+  -- not).+  --+  -- This combinator is used whenever arbitrary look ahead is needed. Since+  -- it pretends that it hasn't consumed any input when @p@ fails, the+  -- ('A.<|>') combinator will try its second alternative even if the first+  -- parser failed while consuming input.+  --+  -- For example, here is a parser that is supposed to parse the word “let”+  -- or the word “lexical”:+  --+  -- >>> parseTest (string "let" <|> string "lexical") "lexical"+  -- 1:1:+  -- unexpected "lex"+  -- expecting "let"+  --+  -- What happens here? The first parser consumes “le” and fails (because it+  -- doesn't see a “t”). The second parser, however, isn't tried, since the+  -- first parser has already consumed some input! 'try' fixes this behavior+  -- and allows backtracking to work:+  --+  -- >>> parseTest (try (string "let") <|> string "lexical") "lexical"+  -- "lexical"+  --+  -- 'try' also improves error messages in case of overlapping alternatives,+  -- because Megaparsec's hint system can be used:+  --+  -- >>> parseTest (try (string "let") <|> string "lexical") "le"+  -- 1:1:+  -- unexpected "le"+  -- expecting "let" or "lexical"+  --+  -- __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)+  -- the whole parser behaves like @p@ succeeded without consuming anything+  -- (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 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, 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 ::+    -- | 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 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 ::+    -- | The parser to run+    m a ->+    m (Either (ParseError s e) a)++  -- | This parser only succeeds at the end of input.+  eof :: m ()++  -- | The parser @'token' test expected@ accepts 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.+  --+  -- For example, the 'Text.Megaparsec.satisfy' parser is implemented as:+  --+  -- > satisfy f = token testToken Set.empty+  -- >   where+  -- >     testToken x = if f x then Just x else Nothing+  --+  -- __Note__: type signature of this primitive was changed in the version+  -- /7.0.0/.+  token ::+    -- | Matching function for the token to parse+    (Token s -> Maybe a) ->+    -- | Used in the error message to mention the items that were expected+    Set (ErrorItem (Token s)) ->+    m a++  -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and+  -- returns it. The supplied predicate @test@ is used to check equality of+  -- 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.chunk':+  --+  -- > 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.+  -- This is done to make its consumption model match how error messages for+  -- this primitive are reported (which becomes an important thing as user+  -- gets more control with primitives like 'withRecovery'):+  --+  -- >>> parseTest (string "abc") "abd"+  -- 1:1:+  -- unexpected "abd"+  -- expecting "abc"+  --+  -- This means, in particular, that it's no longer necessary to use 'try'+  -- 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 ::+    -- | 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 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 the empty chunk.+  --+  -- @since 6.0.0+  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. 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 ::+    -- | 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 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 (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 ::+    -- | Name for a single token in the row+    Maybe String ->+    -- | How many tokens to extract+    Int ->+    -- | A chunk of matching tokens+    m (Tokens s)++  -- | Return the full parser state as a 'State' record.+  getParserState :: m (State s e)++  -- | @'updateParserState' f@ applies the function @f@ to the parser state.+  updateParserState :: (State s e -> State s e) -> m ()++  -- | An escape hatch for defining custom 'MonadParsec' primitives. You+  -- will need to import "Text.Megaparsec.Internal" in order to construct+  -- 'Reply'.+  --+  -- @since 9.4.0+  mkParsec :: (State s e -> Reply e s a) -> m a++----------------------------------------------------------------------------+-- Lifting through MTL++instance (MonadParsec e s m) => MonadParsec e s (L.StateT st m) where+  parseError e = lift (parseError e)+  label n (L.StateT m) = L.StateT $ label n . m+  try (L.StateT m) = L.StateT $ try . m+  lookAhead (L.StateT m) = L.StateT $ \s ->+    (,s) . fst <$> lookAhead (m s)+  notFollowedBy (L.StateT m) = L.StateT $ \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 ->+    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)+  mkParsec f = lift (mkParsec f)++instance (MonadParsec e s m) => MonadParsec e s (S.StateT st m) where+  parseError e = lift (parseError e)+  label n (S.StateT m) = S.StateT $ label n . m+  try (S.StateT m) = S.StateT $ try . m+  lookAhead (S.StateT m) = S.StateT $ \s ->+    (,s) . fst <$> lookAhead (m s)+  notFollowedBy (S.StateT m) = S.StateT $ \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 ->+    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)+  mkParsec f = lift (mkParsec f)++instance (MonadParsec e s m) => MonadParsec e s (L.ReaderT r m) where+  parseError e = lift (parseError e)+  label n (L.ReaderT m) = L.ReaderT $ label n . m+  try (L.ReaderT m) = L.ReaderT $ try . m+  lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m+  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)+  mkParsec f = lift (mkParsec f)++instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where+  parseError e = lift (parseError e)+  label n (L.WriterT m) = L.WriterT $ label n m+  try (L.WriterT m) = L.WriterT $ try m+  lookAhead (L.WriterT m) =+    L.WriterT $+      (,mempty) . fst <$> lookAhead m+  notFollowedBy (L.WriterT m) =+    L.WriterT $+      (,mempty) <$> notFollowedBy (fst <$> m)+  withRecovery r (L.WriterT m) =+    L.WriterT $+      withRecovery (L.runWriterT . r) m+  observing (L.WriterT m) =+    L.WriterT $+      fixs mempty <$> observing m+  eof = lift eof+  token test mt = lift (token test mt)+  tokens e ts = lift (tokens e ts)+  takeWhileP l f = lift (takeWhileP l f)+  takeWhile1P l f = lift (takeWhile1P l f)+  takeP l n = lift (takeP l n)+  getParserState = lift getParserState+  updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)++instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where+  parseError e = lift (parseError e)+  label n (S.WriterT m) = S.WriterT $ label n m+  try (S.WriterT m) = S.WriterT $ try m+  lookAhead (S.WriterT m) =+    S.WriterT $+      (,mempty) . fst <$> lookAhead m+  notFollowedBy (S.WriterT m) =+    S.WriterT $+      (,mempty) <$> notFollowedBy (fst <$> m)+  withRecovery r (S.WriterT m) =+    S.WriterT $+      withRecovery (S.runWriterT . r) m+  observing (S.WriterT m) =+    S.WriterT $+      fixs mempty <$> observing m+  eof = lift eof+  token test mt = lift (token test mt)+  tokens e ts = lift (tokens e ts)+  takeWhileP l f = lift (takeWhileP l f)+  takeWhile1P l f = lift (takeWhile1P l f)+  takeP l n = lift (takeP l n)+  getParserState = lift getParserState+  updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)++-- | @since 5.2.0+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where+  parseError e = lift (parseError e)+  label n (L.RWST m) = L.RWST $ \r s -> label n (m r s)+  try (L.RWST m) = L.RWST $ \r s -> try (m r s)+  lookAhead (L.RWST m) = L.RWST $ \r s -> do+    (x, _, _) <- lookAhead (m r s)+    return (x, s, mempty)+  notFollowedBy (L.RWST m) = L.RWST $ \r s -> do+    notFollowedBy (void $ m 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 ->+    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)+  mkParsec f = lift (mkParsec f)++-- | @since 5.2.0+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where+  parseError e = lift (parseError e)+  label n (S.RWST m) = S.RWST $ \r s -> label n (m r s)+  try (S.RWST m) = S.RWST $ \r s -> try (m r s)+  lookAhead (S.RWST m) = S.RWST $ \r s -> do+    (x, _, _) <- lookAhead (m r s)+    return (x, s, mempty)+  notFollowedBy (S.RWST m) = S.RWST $ \r s -> do+    notFollowedBy (void $ m 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 ->+    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)+  mkParsec f = lift (mkParsec f)++instance (MonadParsec e s m) => MonadParsec e s (IdentityT m) where+  parseError e = lift (parseError e)+  label n (IdentityT m) = IdentityT $ label n m+  try = IdentityT . try . runIdentityT+  lookAhead (IdentityT m) = IdentityT $ lookAhead m+  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+  mkParsec f = lift (mkParsec f)++fixs :: s -> Either a (b, s) -> (Either a b, 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)+{-# INLINE fixs' #-}
− Text/Megaparsec/Combinator.hs 
@@ -1,181 +0,0 @@--- |--- Module      :  Text.Megaparsec.Combinator--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Commonly used generic combinators. Note that all the combinators work--- with 'Applicative' and 'Alternative' instances.--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}--module Text.Megaparsec.Combinator-  ( between-  , choice-  , count-  , count'-  , eitherP-  , endBy-  , endBy1-  , manyTill-  , someTill-  , option-  , sepBy-  , sepBy1-  , sepEndBy-  , sepEndBy1-  , skipMany-  , skipSome )-where--import Control.Applicative-import Control.Monad (void)-import Data.Foldable (asum)--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable)-import Data.Traversable (sequenceA)-#endif---- | @between open close p@ parses @open@, followed by @p@ and @close@.--- Returns the value returned by @p@.------ > braces = between (symbol "{") (symbol "}")--between :: Applicative m => m open -> m close -> m a -> m a-between open close p = open *> p <* close-{-# INLINE between #-}---- | @choice ps@ tries to apply the parsers in the list @ps@ in order, until--- one of them succeeds. Returns the value of the succeeding parser.--choice :: (Foldable f, Alternative m) => f (m a) -> m a-choice = asum-{-# INLINE choice #-}---- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal--- to zero, the parser equals to @return []@. Returns a list of @n@ values.--count :: Applicative m => Int -> m a -> m [a]-count n p = sequenceA (replicate n p)-{-# INLINE count #-}---- | @count' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is not--- positive or @m > n@, the parser equals to @return []@. Returns a list of--- parsed values.------ Please note that @m@ /may/ be negative, in this case effect is the same--- as if it were equal to zero.--count' :: Alternative m => Int -> Int -> m a -> m [a]-count' m' n' p = go m' n'-  where-    go !m !n-      | n <= 0 || m > n = pure []-      | m > 0           = (:) <$> p <*> go (m - 1) (n - 1)-      | otherwise       =-          let f t ts = maybe [] (:ts) t-          in f <$> optional p <*> go 0 (pred n)-{-# INLINE count' #-}---- | Combine two alternatives.------ @since 4.4.0--eitherP :: Alternative m => m a -> m b -> m (Either a b)-eitherP a b = (Left <$> a) <|> (Right <$> b)-{-# INLINE eitherP #-}---- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated and--- ended by @sep@. Returns a list of values returned by @p@.------ > cStatements = cStatement `endBy` semicolon--endBy :: Alternative m => m a -> m sep -> m [a]-endBy p sep = many (p <* sep)-{-# INLINE endBy #-}---- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated and--- ended by @sep@. Returns a list of values returned by @p@.--endBy1 :: Alternative m => m a -> m sep -> m [a]-endBy1 p sep = some (p <* sep)-{-# INLINE endBy1 #-}---- | @manyTill p end@ applies parser @p@ /zero/ or more times until parser--- @end@ succeeds. Returns the list of values returned by @p@. This parser--- can be used to scan comments:------ > simpleComment = string "<!--" >> manyTill anyChar (string "-->")--manyTill :: Alternative m => m a -> m end -> m [a]-manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go)-{-# INLINE manyTill #-}---- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should--- succeed at least once.--someTill :: Alternative m => m a -> m end -> m [a]-someTill p end = (:) <$> p <*> manyTill p end-{-# INLINE someTill #-}---- | @option x p@ tries to apply the parser @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value returned--- by @p@.------ > priority = option 0 (digitToInt <$> digitChar)--option :: Alternative m => a -> m a -> m a-option x p = p <|> pure x-{-# INLINE option #-}---- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated by--- @sep@. Returns a list of values returned by @p@.------ > commaSep p = p `sepBy` comma--sepBy :: Alternative m => m a -> m sep -> m [a]-sepBy p sep = sepBy1 p sep <|> pure []-{-# INLINE sepBy #-}---- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated by--- @sep@. Returns a list of values returned by @p@.--sepBy1 :: Alternative m => m a -> m sep -> m [a]-sepBy1 p sep = (:) <$> p <*> many (sep *> p)-{-# INLINE sepBy1 #-}---- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, separated--- and optionally ended by @sep@. Returns a list of values returned by @p@.--sepEndBy :: Alternative m => m a -> m sep -> m [a]-sepEndBy p sep = sepEndBy1 p sep <|> pure []-{-# INLINE sepEndBy #-}---- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, separated--- and optionally ended by @sep@. Returns a list of values returned by @p@.--sepEndBy1 :: Alternative m => m a -> m sep -> m [a]-sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])---- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping its--- result.------ > space = skipMany spaceChar--skipMany :: Alternative m => m a -> m ()-skipMany p = void $ many p-{-# INLINE skipMany #-}---- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping its--- result.--skipSome :: Alternative m => m a -> m ()-skipSome p = void $ some p-{-# INLINE skipSome #-}
+ 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,360 +1,576 @@+{-# 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–2017 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.--{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}-+--+-- You probably do not want to import this module directly because+-- "Text.Megaparsec" re-exports it anyway. module Text.Megaparsec.Error-  ( ErrorItem (..)-  , ErrorComponent (..)-  , Dec (..)-  , ParseError (..)-  , ShowToken (..)-  , ShowErrorComponent (..)-  , parseErrorPretty-  , sourcePosStackPretty-  , parseErrorTextPretty )+  ( -- * Parse error type+    ErrorItem (..),+    ErrorFancy (..),+    ParseError (..),+    mapParseError,+    errorOffset,+    setErrorOffset,+    ParseErrorBundle (..),+    attachSourcePos,++    -- * Pretty-printing+    ShowErrorComponent (..),+    errorBundlePretty,+    errorBundlePrettyForGhcPreProcessors,+    errorBundlePrettyWith,+    parseErrorPretty,+    parseErrorTextPretty,+    showErrorItem,+  ) where +import Control.Arrow ((>>>)) import Control.DeepSeq-import Control.Monad.Catch+import Control.Exception+import Control.Monad.State.Strict import Data.Data (Data)-import Data.Foldable (concat) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isNothing)+import Data.Proxy import Data.Set (Set)+import qualified Data.Set as E import Data.Typeable (Typeable)+import Data.Void import GHC.Generics-import Prelude hiding (concat)-import Test.QuickCheck hiding (label)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E- import Text.Megaparsec.Pos+import Text.Megaparsec.State+import Text.Megaparsec.Stream+import qualified Text.Megaparsec.Unicode as Unicode -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif+----------------------------------------------------------------------------+-- 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)--instance NFData t => NFData (ErrorItem t)--instance Arbitrary t => Arbitrary (ErrorItem t) where-  arbitrary = oneof-    [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , return EndOfInput ]---- | The type class defines how to represent information about various--- exceptional situations. Data types that are used as custom data component--- in 'ParseError' must be instances of this type class.------ @since 5.0.0--class Ord e => ErrorComponent e where--  -- | Represent the message passed to 'fail' in parser monad.-  ---  -- @since 5.0.0--  representFail :: String -> e--  -- | Represent information about incorrect indentation.-  ---  -- @since 5.0.0--  representIndentation-    :: Ordering -- ^ Desired ordering between reference level and actual level-    -> Pos             -- ^ Reference indentation level-    -> Pos             -- ^ Actual indentation level-    -> e+  = -- | 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 ErrorComponent () where-  representFail _ = ()-  representIndentation _ _ _ = ()+instance (NFData t) => NFData (ErrorItem t) --- | “Default error component”. This is our instance of 'ErrorComponent'--- provided out-of-box.+-- | 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 5.0.0--data Dec-  = DecFail String         -- ^ 'fail' has been used in parser monad-  | DecIndentation Ordering Pos Pos-    -- ^ Incorrect indentation error: desired ordering between reference+-- @since 6.0.0+data ErrorFancy e+  = -- | '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-  deriving (Show, Read, Eq, Ord, Data, Typeable)--instance NFData Dec where-  rnf (DecFail str) = rnf str-  rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act--instance Arbitrary Dec where-  arbitrary = oneof-    [ sized (\n -> do-        k <- choose (0, n `div` 2)-        DecFail <$> vectorOf k arbitrary)-    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]+    ErrorIndentation Ordering Pos Pos+  | -- | Custom error data+    ErrorCustom e+  deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance ErrorComponent Dec where-  representFail        = DecFail-  representIndentation = DecIndentation+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' represents… parse errors. It provides the stack of source--- positions, a set of expected and unexpected tokens as well as a set of--- custom associated data. The data type is 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') instance of the data type allows to merge+-- '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.+-- custom data sets and collections of message items are combined. Note that+-- fancy errors take precedence over trivial errors in merging.+--+-- @since 7.0.0+data ParseError s e+  = -- | 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 = ParseError-  { errorPos        :: NonEmpty SourcePos -- ^ Stack of source positions-  , errorUnexpected :: Set (ErrorItem t)  -- ^ Unexpected items-  , errorExpected   :: Set (ErrorItem t)  -- ^ Expected items-  , errorCustom     :: Set e              -- ^ Associated data, if any-  } 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  = ParseError (initialPos "" :| []) E.empty E.empty E.empty+instance (Stream s, Ord e) => Monoid (ParseError s e) where+  mempty = TrivialError 0 Nothing E.empty   mappend = (<>)   {-# INLINE mappend #-} -instance ( Show t-         , Typeable t-         , Ord t-         , ShowToken t-         , Show e-         , Typeable e-         , ShowErrorComponent 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 -instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where-  arbitrary = ParseError-    <$> (NE.fromList . getNonEmpty <$> arbitrary)-#if MIN_VERSION_QuickCheck(2,8,2)-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary-#else-    <*> (E.fromList <$> arbitrary)-    <*> (E.fromList <$> arbitrary)-    <*> (E.fromList <$> arbitrary)-#endif+-- | Modify the custom data component in a parse error. This could be done+-- via 'fmap' if not for the 'Ord' constraint.+--+-- @since 7.0.0+mapParseError ::+  (Ord e') =>+  (e -> e') ->+  ParseError s e ->+  ParseError s e'+mapParseError _ (TrivialError o u p) = TrivialError o u p+mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) +-- | 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 e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) =-  case pos1 `compare` pos2 of+mergeError ::+  (Stream s, Ord e) =>+  ParseError s e ->+  ParseError s e ->+  ParseError s e+mergeError e1 e2 =+  case errorOffset e1 `compare` errorOffset e2 of     LT -> e2-    EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2)+    EQ ->+      case (e1, e2) of+        (TrivialError s1 u1 p1, TrivialError _ u2 p2) ->+          TrivialError s1 (n u1 u2) (E.union p1 p2)+        (FancyError {}, TrivialError {}) -> e1+        (TrivialError {}, FancyError {}) -> e2+        (FancyError s1 x1, FancyError _ x2) ->+          FancyError s1 (E.union x1 x2)     GT -> e1+  where+    -- NOTE The logic behind this merging is that since we only combine+    -- parse errors that happen at exactly the same position, all the+    -- unexpected items will be prefixes of input stream at that position or+    -- labels referring to the same thing. Our aim here is to choose the+    -- longest prefix (merging with labels and end of input is somewhat+    -- 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 (Just x) Nothing = Just x+    n Nothing (Just y) = Just y+    n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} --- | 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.--class ShowToken a where+-- | A non-empty collection of 'ParseError's equipped with 'PosState' that+-- allows us to pretty-print the errors efficiently and correctly.+--+-- @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) -  -- | Pretty-print non-empty stream of tokens. This function is also used-  -- to print single tokens (represented as singleton lists).-  ---  -- @since 5.0.0+deriving instance+  ( Show s,+    Show (Token s),+    Show e+  ) =>+  Show (ParseErrorBundle s e) -  showTokens :: NonEmpty a -> String+deriving instance+  ( Eq s,+    Eq (Token s),+    Eq e+  ) =>+  Eq (ParseErrorBundle s e) -instance ShowToken Char where-  showTokens = stringPretty+deriving instance+  ( Data s,+    Data (Token s),+    Ord (Token s),+    Data e,+    Ord e+  ) =>+  Data (ParseErrorBundle s e) --- | @stringPretty s@ returns pretty representation of string @s@. This is--- used when printing string tokens in error messages.+instance+  ( NFData s,+    NFData (Token s),+    NFData e+  ) =>+  NFData (ParseErrorBundle s e) -stringPretty :: NonEmpty Char -> String-stringPretty (x:|[])      = charPretty x-stringPretty ('\r':|"\n") = "crlf newline"-stringPretty xs           = "\"" ++ NE.toList xs ++ "\""+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 --- | @charPretty ch@ returns user-friendly string representation of given--- character @ch@, suitable for using in error messages.+-- | Attach 'SourcePos'es to items in a 'Traversable' container given that+-- there is a projection allowing us to get an offset per item.+--+-- Items must be in ascending order with respect to their offsets.+--+-- @since 7.0.0+attachSourcePos ::+  (Traversable t, 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 #-} -charPretty :: Char -> String-charPretty '\NUL' = "null (control character)"-charPretty '\SOH' = "start of heading (control character)"-charPretty '\STX' = "start of text (control character)"-charPretty '\ETX' = "end of text (control character)"-charPretty '\EOT' = "end of transmission (control character)"-charPretty '\ENQ' = "enquiry (control character)"-charPretty '\ACK' = "acknowledge (control character)"-charPretty '\BEL' = "bell (control character)"-charPretty '\BS'  = "backspace"-charPretty '\t'   = "tab"-charPretty '\n'   = "newline"-charPretty '\v'   = "vertical tab"-charPretty '\f'   = "form feed (control character)"-charPretty '\r'   = "carriage return"-charPretty '\SO'  = "shift out (control character)"-charPretty '\SI'  = "shift in (control character)"-charPretty '\DLE' = "data link escape (control character)"-charPretty '\DC1' = "device control one (control character)"-charPretty '\DC2' = "device control two (control character)"-charPretty '\DC3' = "device control three (control character)"-charPretty '\DC4' = "device control four (control character)"-charPretty '\NAK' = "negative acknowledge (control character)"-charPretty '\SYN' = "synchronous idle (control character)"-charPretty '\ETB' = "end of transmission block (control character)"-charPretty '\CAN' = "cancel (control character)"-charPretty '\EM'  = "end of medium (control character)"-charPretty '\SUB' = "substitute (control character)"-charPretty '\ESC' = "escape (control character)"-charPretty '\FS'  = "file separator (control character)"-charPretty '\GS'  = "group separator (control character)"-charPretty '\RS'  = "record separator (control character)"-charPretty '\US'  = "unit separator (control character)"-charPretty '\DEL' = "delete (control character)"-charPretty ' '    = "space"-charPretty '\160' = "non-breaking space"-charPretty x    = "'" ++ [x] ++ "'"+----------------------------------------------------------------------------+-- 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 a component of 'ParseError'.+  showErrorComponent :: a -> String -class Ord a => ShowErrorComponent a where+  -- | 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 -  -- | Pretty-print custom data component of 'ParseError'.+instance ShowErrorComponent Void where+  showErrorComponent = absurd -  showErrorComponent :: a -> String+-- | 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 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 -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"+-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order together with the corresponding offending+-- lines by doing a single pass over the input stream. The rendered 'String'+-- always ends with a newline.+--+-- @since 7.0.0+errorBundlePretty ::+  forall s e.+  ( VisualStream s,+    TraversableStream s,+    ShowErrorComponent e+  ) =>+  -- | Parse error bundle to display+  ParseErrorBundle s e ->+  -- | Textual rendition of the bundle+  String+errorBundlePretty = drop 1 . errorBundlePrettyWith format+  where+    format ::+      Maybe String ->+      SourcePos ->+      ParseError s e ->+      String+    format msline epos e = outChunk+      where+        outChunk =+          "\n"+            <> sourcePosPretty epos+            <> ":\n"+            <> 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 -instance ShowErrorComponent Dec where-  showErrorComponent (DecFail msg) = msg-  showErrorComponent (DecIndentation 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 "+-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order by doing a single pass over the input stream.+--+-- The rendered format is suitable for custom GHC pre-processors (as can be+-- specified with -F -pgmF).+--+-- @since 9.7.0+errorBundlePrettyForGhcPreProcessors ::+  forall s e.+  ( VisualStream s,+    TraversableStream s,+    ShowErrorComponent e+  ) =>+  -- | Parse error bundle to display+  ParseErrorBundle s e ->+  -- | Textual rendition of the bundle+  String+errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format+  where+    format ::+      Maybe String ->+      SourcePos ->+      ParseError s e ->+      String+    format _msline epos e =+      sourcePosPretty epos+        <> ":"+        <> indent (parseErrorTextPretty e) +    indent :: String -> String+    indent =+      lines >>> \case+        [err] -> err+        err -> intercalate "\n" $ map (" " <>) err+ -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. ----- The function is defined as:------ > parseErrorPretty e =--- >   sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e--- -- @since 5.0.0--parseErrorPretty :: ( Ord t-                    , ShowToken t-                    , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render-  -> String            -- ^ Result of rendering+parseErrorPretty ::+  (VisualStream s, ShowErrorComponent e) =>+  -- | Parse error to render+  ParseError s e ->+  -- | Result of rendering+  String parseErrorPretty e =-  sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e+  "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e --- | Pretty-print a stack of source positions.+-- | Pretty-print a textual part of a 'ParseError', that is, everything+-- except for its position. The rendered 'String' always ends with a+-- newline. ----- @since 5.0.0+-- @since 5.1.0+parseErrorTextPretty ::+  forall s e.+  (VisualStream s, ShowErrorComponent e) =>+  -- | Parse error to render+  ParseError s e ->+  -- | Result of rendering+  String+parseErrorTextPretty (TrivialError _ us ps) =+  if isNothing us && E.null ps+    then "unknown parse error\n"+    else+      messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us)+        <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps)+  where+    pxy = Proxy :: Proxy s+parseErrorTextPretty (FancyError _ xs) =+  if E.null xs+    then "unknown fancy parse error\n"+    else unlines (showErrorFancy <$> E.toAscList xs) -sourcePosStackPretty :: NonEmpty SourcePos -> String-sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos-  where (pos :| rest') = ms-        rest           = reverse rest'-        f p = "in file included from " ++ sourcePosPretty p ++ ",\n"+----------------------------------------------------------------------------+-- Helpers --- | Transforms a list of error messages into their textual representation.+-- | 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" -messageItemsPretty :: ShowErrorComponent a-  => String            -- ^ Prefix to prepend-  -> Set a             -- ^ Collection of messages-  -> String            -- ^ Result of rendering+-- | 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++-- | 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++-- | Get length of the “pointer” to display under a given 'ErrorFancy'.+errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int+errorFancyLength = \case+  ErrorCustom a -> errorComponentLen a+  _ -> 1++-- | 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---- | 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.------ @since 5.1.0--parseErrorTextPretty :: ( Ord t-                        , ShowToken t-                        , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorTextPretty (ParseError _ us ps xs) =-  if E.null us && E.null ps && E.null xs-    then "unknown parse error\n"-    else concat-      [ messageItemsPretty "unexpected " us-      , messageItemsPretty "expecting "  ps-      , unlines (showErrorComponent <$> E.toAscList xs) ]+orList (x :| []) = x+orList (x :| [y]) = x <> " or " <> y+orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
+ Text/Megaparsec/Error.hs-boot view
@@ -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
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :  Text.Megaparsec.Error.Builder+-- Copyright   :  © 2015–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- 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.+--+-- @since 6.0.0+module Text.Megaparsec.Error.Builder+  ( -- * Top-level helpers+    err,+    errFancy,++    -- * Error components+    utok,+    utoks,+    ulabel,+    ueof,+    etok,+    etoks,+    elabel,+    eeof,+    fancy,++    -- * Data types+    ET,+    EF,+  )+where++import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Proxy+import Data.Set (Set)+import qualified Data.Set as E+import GHC.Generics+import Text.Megaparsec.Error+import Text.Megaparsec.Stream++----------------------------------------------------------------------------+-- Data types++-- | Auxiliary type for construction of trivial parse errors.+data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))+  deriving (Generic)++deriving instance (Eq (Token s)) => Eq (ET s)++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 (Just x) Nothing = Just x+      n Nothing (Just y) = Just y+      n (Just x) (Just y) = Just (max x y)++instance (Stream s) => Monoid (ET s) where+  mempty = ET Nothing E.empty+  mappend = (<>)++-- | Auxiliary type for construction of fancy parse errors.+newtype EF e = EF (Set (ErrorFancy e))+  deriving (Eq, Ord, Data, Generic)++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+  mappend = (<>)++----------------------------------------------------------------------------+-- Top-level helpers++-- | 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 ::+  -- | '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 :: Token s -> ET s+utok = unexp . Tokens . nes++-- | Construct an “unexpected tokens” error component. Empty chunk produces+-- 'EndOfInput'.+utoks :: forall s. (Stream s) => Tokens s -> ET s+utoks = unexp . canonicalizeTokens (Proxy :: Proxy s)++-- | Construct an “unexpected label” error component. Do not use with empty+-- strings (for empty strings it's bottom).+ulabel :: 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 :: ET s+ueof = unexp EndOfInput++-- | Construct an “expected token” error component.+etok :: Token s -> ET s+etok = expe . Tokens . nes++-- | Construct an “expected tokens” error component. Empty chunk produces+-- 'EndOfInput'.+etoks :: forall s. (Stream s) => Tokens s -> ET s+etoks = expe . canonicalizeTokens (Proxy :: Proxy s)++-- | Construct an “expected label” error component. Do not use with empty+-- strings.+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 :: ET s+eeof = expe EndOfInput++-- | Construct a custom error component.+fancy :: ErrorFancy e -> EF e+fancy = EF . E.singleton++----------------------------------------------------------------------------+-- Helpers++-- | 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 (Token s) -> ET s+unexp u = ET (pure u) E.empty++-- | Lift an expected item into 'ET'.+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,158 +0,0 @@--- |--- Module      :  Text.Megaparsec.Expr--- Copyright   :  © 2015–2017 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 Control.Applicative ((<|>))--import Text.Megaparsec.Combinator-import Text.Megaparsec.Prim---- | 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--- '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---- | @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
@@ -0,0 +1,767 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :  Text.Megaparsec.Internal+-- Copyright   :  © 2015–present Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Internal definitions. Versioning rules do not apply here. Please do not+-- rely on these unless you really know what you're doing.+--+-- @since 6.5.0+module Text.Megaparsec.Internal+  ( -- * Data types+    Hints (..),+    Reply (..),+    Consumption (..),+    Result (..),+    ParsecT (..),++    -- * Helper functions+    toHints,+    withHints,+    accHints,+    refreshHints,+    runParsecT,+    withParsecT,+  )+where++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Combinators+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Trans+import Control.Monad.Writer.Class+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Proxy+import Data.Semigroup+import Data.Set (Set)+import qualified Data.Set as E+import Data.String (IsString (..))+import Text.Megaparsec.Class+import Text.Megaparsec.Error+import Text.Megaparsec.State+import Text.Megaparsec.Stream++----------------------------------------------------------------------------+-- Data types++-- | 'Hints' represent a collection of 'ErrorItem's to be included into+-- '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.+--+-- For example, without hints you could get:+--+-- >>> parseTest (many (char 'r') <* eof) "ra"+-- 1:2:+-- unexpected 'a'+-- expecting end of input+--+-- 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))++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 the returned value) or failure (with the parse+-- error), and parser state at the end of parsing. 'Reply' can also be used+-- to resume parsing.+--+-- See also: 'Consumption', 'Result'.+data Reply e s a = Reply (State s e) Consumption (Result s e a)+  deriving (Functor)++-- | Whether the input has been consumed or not.+--+-- See also: 'Result', 'Reply'.+data Consumption+  = -- | Some part of input stream was consumed+    Consumed+  | -- | No input was consumed+    NotConsumed++-- | Whether the parser has failed or not. On success we include the+-- resulting value, on failure we include a 'ParseError'.+--+-- See also: 'Consumption', 'Reply'.+data Result s e a+  = -- | Parser succeeded (includes hints)+    OK (Hints (Token s)) a+  | -- | Parser failed+    Error (ParseError s e)+  deriving (Functor)++-- | @'ParsecT' e s m a@ is a parser with custom data component of error+-- @e@, stream type @s@, underlying monad @m@ and return type @a@.+newtype ParsecT e s m a = ParsecT+  { unParser ::+      forall b.+      State s e ->+      (a -> State s e -> Hints (Token s) -> m b) -> -- consumed-OK+      (ParseError s e -> State s e -> m b) -> -- consumed-error+      (a -> State s e -> Hints (Token s) -> m b) -> -- empty-OK+      (ParseError s e -> State s e -> m b) -> -- empty-error+      m b+  }++-- | @since 5.3.0+instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where+  (<>) = liftA2 (<>)+  {-# INLINE (<>) #-}+  sconcat = fmap sconcat . sequence+  {-# INLINE sconcat #-}++-- | @since 5.3.0+instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where+  mempty = pure mempty+  {-# INLINE mempty #-}+  mappend = (<>)+  {-# 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+  fromString s = tokens (==) (fromString s)++instance Functor (ParsecT e s m) where+  fmap = pMap++pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b+pMap f p = ParsecT $ \s cok cerr eok eerr ->+  unParser p s (cok . f) cerr (eok . f) eerr+{-# INLINE pMap #-}++-- | 'pure' returns a parser that __succeeds__ without consuming input.+instance (Stream s) => Applicative (ParsecT e s m) where+  pure = pPure+  (<*>) = pAp+  p1 *> p2 = p1 `pBind` const p2+  {-# INLINE (*>) #-}+  p1 <* p2 = do x1 <- p1; void p2; return x1+  {-# INLINE (<*) #-}++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 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+{-# 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+  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+  return = pure+  (>>=) = pBind++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+{-# INLINE pBind #-}++instance (Stream s) => Fail.MonadFail (ParsecT e s m) where+  fail = pFail++pFail :: String -> ParsecT e s m a+pFail msg = ParsecT $ \s@(State _ o _ _) _ _ _ eerr ->+  let d = E.singleton (ErrorFail msg)+   in eerr (FancyError o d) s+{-# 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 = 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 = mkParsecT $ \s ->+    callCC $ \c ->+      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 = mkParsecT $ \s ->+    runParsecT p s `catchError` \e ->+      runParsecT (h e) s++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 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 mkParsecT #-}++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 _ 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 m n = ParsecT $ \s cok cerr eok eerr ->+  let meerr err ms =+        let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')+            neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs)+            neerr err' s' =+              let combinedErr = combineErrors (stateOffset s) err err'+               in eerr combinedErr (longestMatch ms s')+         in unParser n s cok ncerr neok neerr+   in unParser m s cok cerr eok meerr+  where+    combineErrors altOffset e1 e2 = case (e1, e2) of+      (TrivialError o1 u1 p1, TrivialError o2 u2 p2) ->+        -- When merging alternative errors, if one is ahead due to try, we+        -- bring both to the alternative position and union their expected+        -- tokens.+        if o1 > altOffset || o2 > altOffset+          then+            -- At least one error is ahead, normalize to alt position. Only+            -- include expected tokens from errors at the alt position.+            let p1' = if o1 == altOffset then p1 else E.empty+                p2' = if o2 == altOffset then p2 else E.empty+                -- Use the unexpected from the error at alt position, or the+                -- furthest.+                unexp = case (o1 `compare` altOffset, o2 `compare` altOffset) of+                  (EQ, _) -> u1+                  (_, EQ) -> u2+                  _ -> if o1 >= o2 then u1 else u2+             in TrivialError altOffset unexp (E.union p1' p2')+          else e2 <> e1+      _ -> e2 <> e1+{-# INLINE pPlus #-}++-- | From two states, return the one with the greater number of processed+-- tokens. If the numbers of processed tokens are equal, prefer the second+-- state.+longestMatch :: State s e -> State s e -> State s e+longestMatch s1@(State _ o1 _ _) s2@(State _ o2 _ _) =+  case o1 `compare` o2 of+    LT -> s2+    EQ -> s2+    GT -> s1+{-# INLINE longestMatch #-}++-- | @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+  parseError = pParseError+  label = pLabel+  try = pTry+  lookAhead = pLookAhead+  notFollowedBy = pNotFollowedBy+  withRecovery = pWithRecovery+  observing = pObserving+  eof = pEof+  token = pToken+  tokens = pTokens+  takeWhileP = pTakeWhileP+  takeWhile1P = pTakeWhile1P+  takeP = pTakeP+  getParserState = pGetParserState+  updateParserState = pUpdateParserState+  mkParsec = pmkParsec++pParseError ::+  ParseError s e ->+  ParsecT e s m a+pParseError 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+      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'+{-# 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'+{-# INLINE pTry #-}++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+{-# INLINE pLookAhead #-}++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)+      unexpected u = TrivialError o (pure u) E.empty+      cok' _ _ _ = eerr (unexpected what) s+      cerr' _ _ = eok () s mempty+      eok' _ _ _ = eerr (unexpected what) s+      eerr' _ _ = eok () s mempty+   in unParser p s cok' cerr' eok' eerr'+{-# INLINE pNotFollowedBy #-}++pWithRecovery ::+  (Stream s) =>+  (ParseError s e -> ParsecT e s m a) ->+  ParsecT e s m a ->+  ParsecT e s m a+pWithRecovery 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 (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 (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 ::+  (Stream s) =>+  ParsecT e s m a ->+  ParsecT e s m (Either (ParseError s e) a)+pObserving p = ParsecT $ \s cok _ eok _ ->+  let cerr' err s' = cok (Left err) s' mempty+      eerr' err s' = eok (Left err) s' (toHints (stateOffset s') err)+   in unParser p s (cok . Right) cerr' (eok . Right) eerr'+{-# INLINE pObserving #-}++pEof :: forall e s m. (Stream s) => ParsecT e s m ()+pEof = ParsecT $ \s@(State input o pst de) _ _ eok eerr ->+  case take1_ input of+    Nothing -> eok () s mempty+    Just (x, _) ->+      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 -> Maybe a) ->+  Set (ErrorItem (Token s)) ->+  ParsecT e s m a+pToken test ps = ParsecT $ \s@(State input o pst de) cok _ _ eerr ->+  case take1_ input of+    Nothing ->+      let us = pure EndOfInput+       in eerr (TrivialError o us ps) s+    Just (c, cs) ->+      case test c of+        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 o pst de) cok _ eok eerr ->+  let pxy = Proxy :: Proxy s+      unexpected pos' u =+        let us = pure u+            ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts+         in TrivialError pos' us ps+      len = chunkLength pxy tts+   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 o pst de) cok _ eok _ ->+  let pxy = Proxy :: Proxy s+      (ts, input') = takeWhile_ f input+      len = chunkLength pxy ts+      hs =+        case ml >>= NE.nonEmpty of+          Nothing -> mempty+          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 o pst de) cok _ _ eerr ->+  let pxy = Proxy :: Proxy s+      (ts, input') = takeWhile_ f input+      len = chunkLength pxy ts+      el = Label <$> (ml >>= NE.nonEmpty)+      hs =+        case el of+          Nothing -> mempty+          Just l -> (Hints . E.singleton) l+   in if chunkEmpty pxy ts+        then+          let us = pure $+                case take1_ input of+                  Nothing -> EndOfInput+                  Just (t, _) -> Tokens (nes t)+              ps = maybe E.empty E.singleton el+           in eerr+                (TrivialError o us ps)+                (State input o pst de)+        else cok ts (State input' (o + len) pst de) hs+{-# INLINE pTakeWhile1P #-}++pTakeP ::+  forall e s m.+  (Stream s) =>+  Maybe String ->+  Int ->+  ParsecT e s m (Tokens s)+pTakeP ml n' = ParsecT $ \s@(State input o pst de) cok _ _ eerr ->+  let n = max 0 n'+      pxy = Proxy :: Proxy s+      el = Label <$> (ml >>= NE.nonEmpty)+      ps = maybe E.empty E.singleton el+   in case takeN_ n input of+        Nothing ->+          eerr (TrivialError o (pure EndOfInput) ps) s+        Just (ts, input') ->+          let len = chunkLength pxy ts+           in if len /= n+                then+                  eerr+                    (TrivialError (o + len) (pure EndOfInput) ps)+                    (State input o pst de)+                else cok ts (State input' (o + len) pst de) mempty+{-# INLINE pTakeP #-}++pGetParserState :: (Stream s) => ParsecT e s m (State s e)+pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty+{-# INLINE pGetParserState #-}++pUpdateParserState :: (Stream s) => (State s e -> State s e) -> ParsecT e s m ()+pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty+{-# INLINE pUpdateParserState #-}++nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}++----------------------------------------------------------------------------+-- Helper functions++-- | Convert a 'ParseError' record into 'Hints'.+toHints ::+  (Stream s) =>+  -- | Current offset in input stream+  Int ->+  -- | Parse error to convert+  ParseError s e ->+  Hints (Token s)+toHints streamPos = \case+  TrivialError errOffset _ ps ->+    -- NOTE This is important to check here that the error indeed has+    -- 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 == 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@.+--+-- __Note__ that if resulting continuation gets 'ParseError' that has custom+-- data in it, hints are ignored.+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.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 ::+  (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 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) =>+  -- | 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' hs = return $ Reply s' Consumed (OK hs a)+    cerr err s' = return $ Reply s' Consumed (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
@@ -1,119 +1,91 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+ -- |--- Module      :  Text.Megaparsec.Lexer--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com> -- Stability   :  experimental--- Portability :  non-portable------ 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.+-- Portability :  portable ----- This module is intended to be imported qualified:+-- Common token combinators. This module is not public, the functions from+-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". ----- > import qualified Text.Megaparsec.Lexer as L--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf       #-}-{-# LANGUAGE TypeFamilies     #-}-+-- @since 7.0.0 module Text.Megaparsec.Lexer   ( -- * White space-    space-  , lexeme-  , symbol-  , symbol'-  , skipLineComment-  , skipBlockComment-  , skipBlockCommentNested-    -- * Indentation-  , indentLevel-  , incorrectIndent-  , indentGuard-  , nonIndented-  , IndentOpt (..)-  , indentBlock-  , lineFold-    -- * Character and string literals-  , charLiteral-    -- * Numbers-  , integer-  , decimal-  , hexadecimal-  , octal-  , scientific-  , float-  , number-  , signed )+    space,+    lexeme,+    symbol,+    symbol',+  ) where -import Control.Applicative-import Control.Monad (void)-import Data.Char (readLitChar)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (listToMaybe, fromMaybe, isJust)-import Data.Scientific (Scientific, toRealFloat)-import qualified Data.Set as E--import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import qualified Text.Megaparsec.Char as C+import qualified Data.CaseInsensitive as CI+import Text.Megaparsec+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- White space --- | @space spaceChar 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).+-- | @'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). ----- @spaceChar@ is used to parse trivial space characters. You can use--- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as--- your own parser (if you don't want to automatically consume newlines, for--- example).+-- @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.+-- @skipLineComment@ if you don't need anything special. -- -- @blockComment@ is used to parse block (multi-line) comments. You can use--- 'skipBlockComment' if you don't need anything special.+-- @skipBlockComment@ or @skipBlockCommentNested@ if you don't need anything+-- special. ----- Parsing of white space is an important part of any parser. We propose a--- convention where every lexeme parser assumes no spaces before the lexeme--- and consumes all spaces after the lexeme; this is what the 'lexeme'--- combinator does, and so it's enough to wrap every lexeme parser with--- 'lexeme' to achieve this. Note that you'll need to call 'space' manually--- to consume any white space before the first lexeme (i.e. at the beginning--- of the file).--space :: MonadParsec e s m-  => m () -- ^ A parser for a space character (e.g. @'void' 'C.spaceChar'@)-  -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')-  -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')-  -> m ()-space ch line block = hidden . skipMany $ choice [ch, line, block]+-- 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. Typical usage is to supply the first+-- | This is a wrapper for lexemes. The typical usage is to supply the first -- argument (parser that consumes white space, probably defined via 'space') -- and use the resulting function to wrap parsers for every lexeme. -- -- > lexeme  = L.lexeme spaceConsumer--- > integer = lexeme L.integer--lexeme :: MonadParsec e s m-  => m ()              -- ^ How to consume white space after lexeme-  -> m a               -- ^ How to parse actual lexeme-  -> m a+-- > 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@@ -129,370 +101,24 @@ -- > comma     = symbol "," -- > colon     = symbol ":" -- > dot       = symbol "."--symbol :: (MonadParsec e s m, Token s ~ Char)-  => m ()              -- ^ How to consume white space after lexeme-  -> String            -- ^ String to parse-  -> m String-symbol spc = lexeme spc . C.string+symbol ::+  (MonadParsec e s m) =>+  -- | How to consume white space after lexeme+  m () ->+  -- | Symbol to parse+  Tokens s ->+  m (Tokens s)+symbol spc = lexeme spc . string+{-# INLINEABLE symbol #-} --- | Case-insensitive version of 'symbol'. This may be helpful if you're+-- | A case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages.--symbol' :: (MonadParsec e s m, Token s ~ Char)-  => m ()              -- ^ How to consume white space after lexeme-  -> String            -- ^ String to parse (case-insensitive)-  -> m String-symbol' spc = lexeme spc . C.string'---- | Given 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)-  => String            -- ^ Line comment prefix-  -> m ()-skipLineComment prefix = p >> void (manyTill C.anyChar n)-  where p = C.string prefix-        n = lookAhead (void C.newline) <|> eof---- | @skipBlockComment start end@ skips non-nested block comment starting--- with @start@ and ending with @end@.--skipBlockComment :: (MonadParsec e s m, Token s ~ Char)-  => String            -- ^ Start of block comment-  -> String            -- ^ End of block comment-  -> m ()-skipBlockComment start end = p >> void (manyTill C.anyChar n)-  where p = C.string start-        n = C.string end---- | @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 ~ Char)-  => String            -- ^ Start of block comment-  -> String            -- ^ End of block comment-  -> m ()-skipBlockCommentNested start end = p >> void (manyTill e n)-  where e = skipBlockCommentNested start end <|> void C.anyChar-        p = C.string start-        n = C.string end--------------------------------------------------------------------------------- Indentation---- | Return the current indentation level.------ The function is a simple shortcut defined as:------ > indentLevel = sourceColumn <$> getPosition------ @since 4.3.0--indentLevel :: MonadParsec e s m => m Pos-indentLevel = sourceColumn <$> getPosition---- | Fail reporting incorrect indentation error. The error has attached--- information:------     * Desired ordering between reference level and actual level---     * Reference indentation level---     * 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 = failure E.empty E.empty (E.singleton x)-  where x = representIndentation ord ref actual---- | @indentGuard spaceConsumer ord ref@ first consumes all white space--- (indentation) with @spaceConsumer@ parser, then it checks the column--- position. Ordering between current indentation level and the reference--- indentation level @ref@ should be @ord@, otherwise the parser fails. On--- success the current column position is returned.------ When you want to parse a block of indentation, first run this parser with--- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@—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 sc ord ref = do-  sc-  actual <- indentLevel-  if compare actual ref == ord-    then return actual-    else incorrectIndent ord ref actual---- | Parse a non-indented construction. This ensures that there is no--- indentation before actual data. Useful, for example, as a wrapper for--- 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 sc p = indentGuard sc EQ (unsafePos 1) *> p---- | The data type represents available 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-    -- level (if 'Nothing', use level of the first indented token); the-    -- second argument tells how to get final result, and 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-    -- be present---- | 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.------ 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.------ @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 sc r = do-  sc-  ref <- indentLevel-  a   <- r-  case a of-    IndentNone x -> sc *> return x-    IndentMany indent f p -> do-      mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)-      done <- isJust <$> optional eof-      case (mlvl, done) of-        (Just lvl, False) ->-          indentedItems ref (fromMaybe lvl indent) sc p >>= f-        _ -> sc *> f []-    IndentSome indent f p -> do-      lvl <- C.eol *> indentGuard sc GT ref-      x   <- p-      xs  <- indentedItems ref (fromMaybe lvl indent) sc p-      f (x:xs)---- | 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 ref lvl sc p = go-  where-    go = do-      sc-      pos  <- indentLevel-      done <- isJust <$> optional eof-      if done-        then return []-        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.------ An example should clarify the usage pattern:------ > sc = L.space (void spaceChar) empty empty--- >--- > myFold = L.lineFold sc $ \sc' -> do--- >   L.symbol sc' "foo"--- >   L.symbol sc' "bar"--- >   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 sc action =-  sc >> indentLevel >>= action . void . indentGuard sc GT--------------------------------------------------------------------------------- Character and string literals---- | The lexeme parser parses a single literal character without quotes. The--- purpose of this parser is to help with parsing of conventional escape--- sequences. It's your responsibility to take care of character literal--- syntax in your language (by surrounding it with single quotes or--- similar).------ The literal character is parsed according to the grammar rules defined in--- the Haskell report.------ Note that you can use this parser as a building block to parse various--- string literals:------ > stringLiteral = char '"' >> manyTill L.charLiteral (char '"')------ If you want to write @stringLiteral@ that adheres to the Haskell report--- though, you'll need to take care of the @\\&@ combination which is not a--- character, but can be used to separate characters (as in @\"\\291\\&4\"@--- which is two characters long):------ > stringLiteral = catMaybes <$> (char '"' >> manyTill ch (char '"'))--- >   where ch = (Just <$> L.charLiteral) <|> (Nothing <$ string "\\&")--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@(x:_) <- lookAhead $ count' 1 8 C.anyChar-  case listToMaybe (readLitChar r) of-    Just (c, r') -> count (length r - length r') C.anyChar >> return c-    Nothing      -> unexpected (Tokens (x:|[]))--------------------------------------------------------------------------------- Numbers---- | Parse an integer without sign in decimal representation (according to--- the format of integer literals described in the Haskell report).------ If you need to parse signed integers, see 'signed' combinator.--integer :: (MonadParsec e s m, Token s ~ Char) => m Integer-integer = decimal <?> "integer"---- | The same as 'integer', but 'integer' is 'label'ed with “integer” label,--- while this parser is labeled with “decimal integer”.--decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer-decimal = nump "" C.digitChar <?> "decimal integer"---- | Parse an integer in hexadecimal representation. Representation of--- 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--- parsing the number itself.------ For example you can make it conform to Haskell report like this:------ > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal--hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer-hexadecimal = nump "0x" C.hexDigitChar <?> "hexadecimal integer"---- | Parse an integer in octal representation. Representation of 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--- the number itself.--octal :: (MonadParsec e s m, Token s ~ Char) => m Integer-octal = nump "0o" C.octDigitChar <?> "octal integer"---- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then--- prepends @prefix@ to returned value and tries to interpret the result as--- an integer according to Haskell syntax.--nump :: MonadParsec e s m => String -> m Char -> m Integer-nump prefix baseDigit = read . (prefix ++) <$> some baseDigit---- | Parse a floating point value as a 'Scientific' number. 'Scientific' is--- great for parsing of arbitrary precision numbers coming from an untrusted--- source. See documentation in "Data.Scientific" for more information.--- Representation of the floating point value is expected to be according to--- the Haskell report.------ This function does not parse sign, if you need to parse signed numbers,--- see 'signed'.------ @since 5.0.0--scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific-scientific = label "floating point number" (read <$> f)-  where f = (++) <$> some C.digitChar <*> (fraction <|> fExp)---- | Parse a floating point number without sign. This is a simple shortcut--- defined as:------ > float = toRealFloat <$> scientific--float :: (MonadParsec e s m, Token s ~ Char) => m Double-float = toRealFloat <$> scientific---- | This is a helper for 'float' parser. It parses fractional part of--- floating point number, that is, dot and everything after it.--fraction :: (MonadParsec e s m, Token s ~ Char) => m String-fraction = do-  void (C.char '.')-  d <- some C.digitChar-  e <- option "" fExp-  return ('.' : d ++ e)---- | This helper parses exponent of floating point numbers.--fExp :: (MonadParsec e s m, Token s ~ Char) => m String-fExp = do-  expChar <- C.char' 'e'-  signStr <- option "" (pure <$> choice (C.char <$> "+-"))-  d       <- some C.digitChar-  return (expChar : signStr ++ d)---- | Parse a number: either integer or floating point. The parser can handle--- overlapping grammars graciously. Use functions like--- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and--- extract integer or real values.--number :: (MonadParsec e s m, Token s ~ Char) => m Scientific-number = label "number" (read <$> f)-  where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp)---- | @signed space p@ parser parses an optional sign, then if there is a--- sign it will consume optional white space (using @space@ parser), then it--- runs parser @p@ which should return a number. Sign of the number is--- changed according to previously parsed sign.------ For example, to parse signed integer you can write:------ > lexeme        = L.lexeme spaceConsumer--- > integer       = lexeme L.integer--- > signedInteger = L.signed spaceConsumer integer--signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a-signed spc p = ($) <$> option id (lexeme spc sign) <*> p---- | Parse a sign and return either 'id' or 'negate' according to parsed--- sign.--sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a)-sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate)+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–2017 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.Combinator (choice)-import Text.Megaparsec.Prim--#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–2017 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -8,92 +13,78 @@ -- 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.--{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TupleSections              #-}-+-- and column number.+--+-- You probably do not want to import this module directly because+-- "Text.Megaparsec" re-exports it anyway. module Text.Megaparsec.Pos   ( -- * Abstract position-    Pos-  , mkPos-  , unPos-  , unsafePos-  , InvalidPosException (..)+    Pos,+    mkPos,+    unPos,+    pos1,+    defaultTabWidth,+    InvalidPosException (..),+     -- * Source position-  , SourcePos (..)-  , initialPos-  , sourcePosPretty-    -- * Helpers implementing default behaviors-  , defaultUpdatePos-  , defaultTabWidth )+    SourcePos (..),+    initialPos,+    sourcePosPretty,+  ) where  import Control.DeepSeq-import Control.Monad.Catch+import Control.Exception import Data.Data (Data)-import Data.Semigroup-import Data.Typeable (Typeable) import GHC.Generics-import Test.QuickCheck -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Word (Word)-#endif- ---------------------------------------------------------------------------- -- Abstract position --- | Positive integer that is used to represent line number, column number,--- and similar things like indentation level. 'Semigroup' instance can be--- used to safely and purely add 'Pos'es together.+-- | 'Pos' is the type for positive integers. This is used to represent line+-- number, column number, and similar things like indentation level.+-- 'Semigroup' instance can be used to safely and efficiently add 'Pos'es+-- together. -- -- @since 5.0.0--newtype Pos = Pos Word-  deriving (Show, Eq, Ord, Data, Typeable, NFData)--instance Arbitrary Pos where-  arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))+newtype Pos = Pos Int+  deriving (Show, Eq, Ord, Data, Generic, NFData) --- | Construction of 'Pos' from an instance of 'Integral'. The function--- throws 'InvalidPosException' when given non-positive argument. Note that--- the function is polymorphic with respect to 'MonadThrow' @m@, so you can--- get result inside of 'Maybe', for example.+-- | Construction of 'Pos' from 'Int'. The function throws+-- 'InvalidPosException' when given a non-positive argument. ----- @since 5.0.0--mkPos :: (Integral a, MonadThrow m) => a -> m Pos-mkPos x =-  if x < 1-    then throwM InvalidPosException-    else (return . Pos . fromIntegral) x+-- @since 6.0.0+mkPos :: Int -> Pos+mkPos a =+  if a <= 0+    then throw (InvalidPosException a)+    else Pos a {-# INLINE mkPos #-} --- | Dangerous construction of 'Pos'. Use when you know for sure that--- argument is positive.+-- | Extract 'Int' from 'Pos'. ----- @since 5.0.0+-- @since 6.0.0+unPos :: Pos -> Int+unPos (Pos w) = w+{-# INLINE unPos #-} -unsafePos :: Word -> Pos-unsafePos x =-  if x < 1-    then error "Text.Megaparsec.Pos.unsafePos"-    else Pos x-{-# INLINE unsafePos #-}+-- | Position with value 1.+--+-- @since 6.0.0+pos1 :: Pos+pos1 = mkPos 1 --- | Extract 'Word' from 'Pos'.+-- | Value of tab width used by default. Always prefer this constant when+-- you want to refer to the default tab width because actual value /may/+-- change in future. --+-- Currently:+--+-- > defaultTabWidth = mkPos 8+-- -- @since 5.0.0--unPos :: Pos -> Word-unPos (Pos w) = w-{-# INLINE unPos #-}+defaultTabWidth :: Pos+defaultTabWidth = mkPos 8  instance Semigroup Pos where   (Pos x) <> (Pos y) = Pos (x + y)@@ -103,92 +94,52 @@   readsPrec d =     readParen (d > 10) $ \r1 -> do       ("Pos", r2) <- lex r1-      (x,     r3) <- readsPrec 11 r2-      (,r3) <$> mkPos (x :: Integer)--instance Arbitrary SourcePos where-  arbitrary = SourcePos-    <$> sized (\n -> do-          k <- choose (0, n `div` 2)-          vectorOf k arbitrary)-    <*> (unsafePos <$> choose (1, 1000))-    <*> (unsafePos <$> choose (1,  100))+      (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-  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 --- | The data type @SourcePos@ represents source positions. It contains the+-- | The data type 'SourcePos' represents source positions. It contains the -- 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 :: String -> SourcePos-initialPos n = SourcePos n u u-  where u = unsafePos 1-{-# INLINE initialPos #-}+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-  | otherwise = n ++ ":" ++ showLC-  where showLC = show (unPos l) ++ ":" ++ show (unPos c)--------------------------------------------------------------------------------- Helpers implementing default behaviors---- | Update a source position given a character. The first argument--- specifies the tab width. If the character is a newline (\'\\n\') the line--- number is incremented by 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.------ @since 5.0.0--defaultUpdatePos-  :: Pos               -- ^ Tab width-  -> SourcePos         -- ^ Current position-  -> Char              -- ^ Current token-  -> (SourcePos, SourcePos) -- ^ Actual position and incremented position-defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos)+  | null n = showLC+  | otherwise = n <> ":" <> showLC   where-    u = unsafePos 1-    w = unPos width-    c' = unPos c-    npos =-      case ch of-        '\n' -> SourcePos n (l <> u) u-        '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w))-        _    -> SourcePos n l (c <> u)---- | Value of tab width used by default. Always prefer this constant when--- you want to refer to the default tab width because actual value /may/--- change in future.--defaultTabWidth :: Pos-defaultTabWidth = unsafePos 8+    showLC = show (unPos l) <> ":" <> show (unPos c)
− Text/Megaparsec/Prim.hs 
@@ -1,1410 +0,0 @@--- |--- Module      :  Text.Megaparsec.Prim--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ The primitive parser combinators.--{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# OPTIONS_HADDOCK not-home            #-}--module Text.Megaparsec.Prim-  ( -- * Data types-    State (..)-  , Stream (..)-  , Parsec-  , ParsecT-    -- * Primitive combinators-  , MonadParsec (..)-  , (<?>)-  , unexpected-  , match-  , region-    -- * Parser state combinators-  , getInput-  , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , setParserState-    -- * Running parser-  , parse-  , parseMaybe-  , parseTest-  , runParser-  , runParser'-  , runParserT-  , runParserT'-    -- * Debugging-  , dbg )-where--import Control.DeepSeq-import Control.Monad-import Control.Monad.Cont.Class-import Control.Monad.Error.Class-import Control.Monad.Identity-import Control.Monad.Reader.Class-import Control.Monad.State.Class hiding (state)-import Control.Monad.Trans-import Control.Monad.Trans.Identity-import Data.Data (Data)-import Data.Foldable (foldl')-import Data.List (genericTake)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid hiding ((<>))-import Data.Proxy-import Data.Semigroup-import Data.Set (Set)-import Data.Typeable (Typeable)-import Debug.Trace-import GHC.Generics-import Prelude hiding (all)-import Test.QuickCheck hiding (Result (..), label)-import qualified Control.Applicative               as A-import qualified Control.Monad.Fail                as Fail-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-import qualified Data.ByteString.Char8             as B-import qualified Data.ByteString.Lazy.Char8        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--import Text.Megaparsec.Error-import Text.Megaparsec.Pos--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Word (Word)-#endif--------------------------------------------------------------------------------- Data types---- | This is the Megaparsec's state, it's parametrized over stream type @s@.--data State s = State-  { stateInput :: s-    -- ^ Current input (already processed input is removed from the stream)-  , statePos :: NonEmpty SourcePos-    -- ^ Current position (column + line number) with support for include files-  , stateTokensProcessed :: {-# UNPACK #-} !Word-    -- ^ Number of processed tokens so far-    ---    -- @since 5.2.0-  , stateTabWidth :: Pos-    -- ^ Tab width to use-  } deriving (Show, Eq, Data, Typeable, Generic)--instance NFData s => NFData (State s)--instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State-    <$> arbitrary-    <*> (NE.fromList . getNonEmpty <$> arbitrary)-    <*> choose (1, 10000)-    <*> (unsafePos <$> choose (1, 20))---- | 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.------ See also: 'Consumption', 'Result'.--data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)---- | This data structure represents an aspect of result of parser's work.------ See also: 'Result', 'Reply'.--data Consumption-  = Consumed -- ^ Some part of input stream was consumed-  | Virgin   -- ^ No input was consumed---- | This data structure represents an aspect of result of parser's work.------ See also: 'Consumption', 'Reply'.--data Result t e a-  = OK a                   -- ^ Parser succeeded-  | Error (ParseError t e) -- ^ Parser failed---- | 'Hints' represent collection of strings to be included into--- 'ParserError' as “expected” message items when a parser fails without--- consuming input right after successful parser that produced the hints.------ For example, without hints you could get:------ >>> parseTest (many (char 'r') <* eof) "ra"--- 1:2:--- unexpected 'a'--- expecting end of input------ We're getting better error messages with 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)] deriving (Semigroup, Monoid)---- | Convert 'ParseError' record into 'Hints'.--toHints :: ParseError t e -> Hints t-toHints err = Hints hints-  where hints = if E.null msgs then [] else [msgs]-        msgs  = errorExpected err-{-# INLINE toHints #-}---- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@.------ Note that if resulting continuation gets 'ParseError' that has only--- custom data in it (no “unexpected” or “expected” items), 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 (Hints ps') c e@(ParseError pos us ps xs) =-  if E.null us && E.null ps && not (E.null xs)-    then c e-    else c (ParseError pos us (E.unions (ps : ps')) xs)-{-# 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 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 #-}---- | An instance of @Stream s@ has stream type @s@. Token type is determined--- by the stream and can be found via 'Token' type function.--class Ord (Token s) => Stream s where--  -- | Type of token in stream.-  ---  -- @since 5.0.0--  type Token s :: *--  -- | Get next token from the stream. If the stream is empty, return-  -- 'Nothing'.--  uncons :: s -> Maybe (Token s, s)--  -- | Update position in stream given tab width, current position, and-  -- current token. The result is a tuple where the first element will be-  -- used to report parse errors for current token, while the second element-  -- is the incremented position that will be stored in the parser's state.-  -- The stored (incremented) position is used whenever position can't-  -- be\/shouldn't be updated by consuming a token. For example, when using-  -- 'failure', we don't grab a new token (we need to fail right were we are-  -- now), so error position will be taken from parser's state.-  ---  -- When you work with streams where elements do not contain information-  -- about their position in input, the result is usually consists of the-  -- third argument unchanged and incremented position calculated with-  -- respect to current token. This is how default instances of 'Stream'-  -- work (they use 'defaultUpdatePos', which may be a good starting point-  -- for your own position-advancing function).-  ---  -- When you wish to deal with a stream of tokens where every token “knows”-  -- its start and end position in input (for example, you have produced the-  -- stream with Happy\/Alex), then the best strategy is to use the start-  -- position as the actual element position and provide the end position of-  -- the token as the incremented one.-  ---  -- @since 5.0.0--  updatePos-    :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective)-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> (SourcePos, SourcePos) -- ^ Actual position and incremented position--instance Stream String where-  type Token String = Char-  uncons [] = Nothing-  uncons (t:ts) = Just (t, ts)-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream B.ByteString where-  type Token B.ByteString = Char-  uncons = B.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream BL.ByteString where-  type Token BL.ByteString = Char-  uncons = BL.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream T.Text where-  type Token T.Text = Char-  uncons = T.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream TL.Text where-  type Token TL.Text = Char-  uncons = TL.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}---- | @Parsec@ is a non-transformer variant of the more general 'ParsecT'--- monad transformer.--type Parsec e s = ParsecT e s Identity---- | @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 }--instance (ErrorComponent e, Stream s, Semigroup a)-    => Semigroup (ParsecT e s m a) where-  (<>) = A.liftA2 (<>)-  {-# INLINE (<>) #-}--instance (ErrorComponent e, Stream s, Monoid a)-    => Monoid (ParsecT e s m a) where-  mempty = pure mempty-  {-# INLINE mempty #-}-  mappend = A.liftA2 mappend-  {-# INLINE mappend #-}--instance Functor (ParsecT e s m) where-  fmap = pMap--pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b-pMap f p = ParsecT $ \s cok cerr eok eerr ->-  unParser p s (cok . f) cerr (eok . f) eerr-{-# INLINE pMap #-}--instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where-  pure     = pPure-  (<*>)    = pAp-  p1 *> p2 = p1 `pBind` const p2-  p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }--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-{-# INLINE pAp #-}--instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where-  empty  = mzero-  (<|>)  = mplus--instance (ErrorComponent e, Stream s)-    => Monad (ParsecT e s m) where-  return = pure-  (>>=)  = pBind-  fail   = Fail.fail--pPure :: a -> ParsecT e s m a-pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty-{-# INLINE pPure #-}--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-{-# INLINE pBind #-}--instance (ErrorComponent e, Stream s)-    => Fail.MonadFail (ParsecT e s m) where-  fail = pFail--pFail :: ErrorComponent e => String -> ParsecT e s m a-pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (ParseError pos E.empty E.empty d) s-  where d = E.singleton (representFail msg)-{-# INLINE pFail #-}--mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a-mkPT 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-        Error e -> cerr e s'-    Virgin ->-      case result of-        OK    x -> eok x s' mempty-        Error e -> eerr e s'--instance (ErrorComponent e, Stream s, MonadIO m)-    => MonadIO (ParsecT e s m) where-  liftIO = lift . liftIO--instance (ErrorComponent e, 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)--instance (ErrorComponent e, Stream s, MonadState st m)-    => MonadState st (ParsecT e s m) where-  get = lift get-  put = lift . put--instance (ErrorComponent e, Stream s, MonadCont m)-    => MonadCont (ParsecT e s m) where-  callCC f = mkPT $ \s ->-    callCC $ \c ->-      runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s-    where pack s a = Reply s Virgin (OK a)--instance (ErrorComponent e, Stream s, MonadError e' m)-    => MonadError e' (ParsecT e s m) where-  throwError = lift . throwError-  p `catchError` h = mkPT $ \s ->-    runParsecT p s `catchError` \e ->-      runParsecT (h e) s--instance (ErrorComponent 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 (ParseError pos E.empty E.empty E.empty) s-{-# INLINE pZero #-}--pPlus :: (ErrorComponent 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 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-{-# INLINE pPlus #-}---- | From two states, return the one with the greater number of processed--- tokens. If the numbers of processed tokens are equal, prefer the second--- state.--longestMatch :: State s -> State s -> State s-longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) =-  case tp1 `compare` tp2 of-    LT -> s2-    EQ -> s2-    GT -> s1-{-# INLINE longestMatch #-}--instance MonadTrans (ParsecT e s) where-  lift amb = ParsecT $ \s _ _ eok _ ->-    amb >>= \a -> eok a s mempty--------------------------------------------------------------------------------- Primitive combinators---- | Type class describing parsers independent of input type.--class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m)-    => MonadParsec e s m | m -> e s where--  -- | The most general way to stop parsing and report a 'ParseError'.-  ---  -- 'unexpected' is defined in terms of this function:-  ---  -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty-  ---  -- @since 4.2.0--  failure-    :: Set (ErrorItem (Token s)) -- ^ Unexpected items-    -> Set (ErrorItem (Token s)) -- ^ Expected items-    -> Set e                     -- ^ Custom data-    -> 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.--  hidden :: m a -> m a-  hidden = label ""--  -- | The parser @try p@ behaves like parser @p@, except that it backtracks-  -- the parser state when @p@ fails (either consuming input or not).-  ---  -- This combinator is used whenever arbitrary look ahead is needed. Since-  -- it pretends that it hasn't consumed any input when @p@ fails, the-  -- ('A.<|>') combinator will try its second alternative even when the-  -- first parser failed while consuming input.-  ---  -- For example, here is a parser that is supposed to parse the word “let”-  -- or the word “lexical”:-  ---  -- >>> parseTest (string "let" <|> string "lexical") "lexical"-  -- 1:1:-  -- unexpected "lex"-  -- expecting "let"-  ---  -- What happens here? The first parser consumes “le” and fails (because it-  -- doesn't see a “t”). The second parser, however, isn't tried, since the-  -- first parser has already consumed some input! 'try' fixes this behavior-  -- and allows backtracking to work:-  ---  -- >>> parseTest (try (string "let") <|> string "lexical") "lexical"-  -- "lexical"-  ---  -- @try@ also improves error messages in case of overlapping alternatives,-  -- because Megaparsec's hint system can be used:-  ---  -- >>> parseTest (try (string "let") <|> string "lexical") "le"-  -- 1:1:-  -- 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-  -- alternatives are complex, composite parsers.--  try :: m a -> m a--  -- | If @p@ in @lookAhead p@ succeeds (either consuming input or not) the-  -- whole parser behaves like @p@ succeeded without consuming anything-  -- (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-  -- 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-  -- 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--  -- | @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.-  ---  -- @since 5.1.0--  observing-    :: m a-    -> m (Either (ParseError (Token s) e) a)--  -- | This parser only succeeds at the end of the 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.-  ---  -- This is the most primitive combinator for accepting tokens. For-  -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:-  ---  -- > satisfy f = token testChar Nothing-  -- >   where-  -- >     testChar x =-  -- >       if f x-  -- >         then Right x-  -- >         else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty)--  token-    :: (Token s -> Either ( Set (ErrorItem (Token s))-                          , Set (ErrorItem (Token s))-                          , Set e ) a)-       -- ^ Matching function for the token to parse, it allows to construct-       -- arbitrary error message on failure as well; sets in three-tuple-       -- are: unexpected items, expected items, and custom data pieces-    -> Maybe (Token s) -- ^ Token to report when input stream is empty-    -> m a--  -- | The parser @tokens test@ parses a list of tokens and returns it.-  -- Supplied predicate @test@ is used to check equality of given and parsed-  -- tokens.-  ---  -- This can be used for example to write 'Text.Megaparsec.Char.string':-  ---  -- > string = 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.-  -- This is done to make its consumption model match how error messages for-  -- this primitive are reported (which becomes an important thing as user-  -- gets more control with primitives like 'withRecovery'):-  ---  -- >>> parseTest (string "abc") "abd"-  -- 1:1:-  -- unexpected "abd"-  -- expecting "abc"-  ---  -- This means, in particular, that it's no longer necessary to use 'try'-  -- 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-    :: (Token s -> Token s -> Bool)-       -- ^ Predicate to check equality of tokens-    -> [Token s]-       -- ^ List of tokens to parse-    -> m [Token s]--  -- | Return the full parser state as a 'State' record.--  getParserState :: m (State s)--  -- | @updateParserState f@ applies the function @f@ to the parser state.--  updateParserState :: (State s -> State s) -> m ()--instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where-  failure           = pFailure-  label             = pLabel-  try               = pTry-  lookAhead         = pLookAhead-  notFollowedBy     = pNotFollowedBy-  withRecovery      = pWithRecovery-  observing         = pObserving-  eof               = pEof-  token             = pToken-  tokens            = pTokens-  getParserState    = pGetParserState-  updateParserState = pUpdateParserState--pFailure-  :: Set (ErrorItem (Token s))-  -> Set (ErrorItem (Token s))-  -> Set e-  -> ParsecT e s m a-pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (ParseError pos us ps xs) s-{-# INLINE pFailure #-}--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 err-        { errorExpected = maybe E.empty E.singleton el }-  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'-{-# INLINE pTry #-}--pLookAhead :: ParsecT e s m a -> ParsecT e s m a-pLookAhead p = ParsecT $ \s _ cerr eok eerr ->-  let eok' a _ _ = eok a s mempty-  in unParser p s eok' cerr eok' eerr-{-# INLINE pLookAhead #-}--pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()-pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr ->-  let what = maybe EndOfInput (Tokens . nes . fst) (uncons input)-      unexpect u = ParseError pos (E.singleton u) E.empty E.empty-      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'-{-# INLINE pNotFollowedBy #-}--pWithRecovery-  :: (ParseError (Token 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 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 err)-            rcerr   _ _ = eerr err ms-            reok x s' _ = eok x s' (toHints 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 p = ParsecT $ \s cok _ eok _ ->-  let cerr' err s' = cok (Left err) s' mempty-      eerr' err s' = eok (Left err) s' (toHints 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 ->-  case uncons input of-    Nothing    -> eok () s mempty-    Just (x,_) ->-      let !apos = fst (updatePos (Proxy :: Proxy s) w pos x)-      in eerr ParseError-          { errorPos        = apos:|z-          , errorUnexpected = (E.singleton . Tokens . nes) x-          , errorExpected   = E.singleton EndOfInput-          , errorCustom     = E.empty }-          (State input (apos:|z) tp w)-{-# INLINE pEof #-}--pToken :: forall e s m a. Stream s-  => (Token s -> Either ( Set (ErrorItem (Token s))-                        , Set (ErrorItem (Token s))-                        , Set e ) a)-  -> Maybe (Token s)-  -> ParsecT e s m a-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->-  case uncons input of-    Nothing -> eerr ParseError-      { errorPos        = pos:|z-      , errorUnexpected = E.singleton EndOfInput-      , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtoken-      , errorCustom     = E.empty } s-    Just (c,cs) ->-      let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c-      in case test c of-        Left (us, ps, xs) ->-          apos `seq` eerr-            (ParseError (apos:|z) us ps xs)-            (State input (apos:|z) tp w)-        Right x ->-          let newstate = State cs (npos:|z) (tp + 1) w-          in npos `seq` cok x newstate mempty-{-# INLINE pToken #-}--pTokens :: forall e s m. Stream s-  => (Token s -> Token s -> Bool)-  -> [Token s]-  -> ParsecT e s m [Token s]-pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty-pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->-  let updatePos' = updatePos (Proxy :: Proxy s) w-      toTokens   = Tokens . NE.fromList . reverse-      unexpect pos' u = ParseError-        { errorPos        = pos'-        , errorUnexpected = E.singleton u-        , errorExpected   = (E.singleton . Tokens . NE.fromList) tts-        , errorCustom     = E.empty }-      go _ [] is rs =-        let ris   = reverse is-            (npos, tp') = foldl'-              (\(p, n) t -> (snd (updatePos' p t), n + 1))-              (pos, tp)-              ris-        in cok ris (State rs (npos:|z) tp' w) mempty-      go apos (t:ts) is rs =-        case uncons rs of-          Nothing ->-            apos `seq` eerr-              (unexpect (apos:|z) (toTokens is))-              (State input (apos:|z) tp w)-          Just (x,xs) ->-            if test t x-              then go apos ts (x:is) xs-              else apos `seq` eerr-                     (unexpect (apos:|z) . toTokens $ x:is)-                     (State input (apos:|z) tp w)-  in case uncons input of-       Nothing ->-         eerr (unexpect (pos:|z) EndOfInput) s-       Just (x,xs) ->-         let t:ts = tts-             apos = fst (updatePos' pos x)-         in if test t x-              then go apos ts [x] xs-              else apos `seq` eerr-                     (unexpect (apos:|z) $ Tokens (nes x))-                     (State input (apos:|z) tp w)-{-# INLINE pTokens #-}--pGetParserState :: ParsecT e s m (State s)-pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty-{-# INLINE pGetParserState #-}--pUpdateParserState :: (State s -> State s) -> ParsecT e s m ()-pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty-{-# INLINE pUpdateParserState #-}---- | A synonym for 'label' in the form of an operator.--infix 0 <?>--(<?>) :: MonadParsec e s m => m a -> String -> m a-(<?>) = flip label---- | The parser @unexpected item@ fails with an error message telling about--- unexpected item @item@ without consuming any input.--unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a-unexpected item = failure (E.singleton item) E.empty E.empty-{-# INLINE unexpected #-}---- | Return both the result of a parse and the list of tokens that were--- consumed during parsing. This relies on the change of the--- 'stateTokensProcessed' value to evaluate how many tokens were consumed.------ @since 5.3.0--match :: MonadParsec e s m => m a -> m ([Token s], a)-match p = do-  tp  <- getTokensProcessed-  s   <- getInput-  r   <- p-  tp' <- getTokensProcessed-  return (streamTake (tp' - tp) s, r)---- | 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.------ @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 processing applies to-  -> m a-region f m = do-  r <- observing m-  case r of-    Left err -> do-      let ParseError {..} = f err-      updateParserState $ \st -> st { statePos = errorPos }-      failure errorUnexpected errorExpected errorCustom-    Right x -> return x---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}--------------------------------------------------------------------------------- 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)---- | Return the current source position.------ 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'.------ @since 5.3.0--getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos)-getNextTokenPosition = do-  State {..} <- getParserState-  let f = fst . updatePos (Proxy :: Proxy s) stateTabWidth (NE.head statePos)-  return (f . fst <$> uncons stateInput)---- | @setPosition pos@ sets the current source position to @pos@.------ 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---- | Push a position into stack of positions and continue parsing working--- with this position. Useful for working with include files and the like.------ See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.------ @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'.------ See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.------ @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---- | Get the number of tokens processed so far.------ @since 5.2.0--getTokensProcessed :: MonadParsec e s m => m Word-getTokensProcessed = stateTokensProcessed <$> getParserState---- | Set the number of tokens processed so far.------ @since 5.2.0--setTokensProcessed :: MonadParsec e s m => Word -> 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@.--setParserState :: MonadParsec e s m => State s -> m ()-setParserState st = updateParserState (const st)--------------------------------------------------------------------------------- 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.------ > main = case (parse numbers "" "11,2,43") of--- >          Left err -> putStr (parseErrorPretty err)--- >          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-parse = runParser---- | @parseMaybe p input@ runs the parser @p@ on @input@ and returns the--- result inside 'Just' on success and 'Nothing' on failure. This function--- also parses 'eof', so if the parser doesn't consume all of its input, it--- 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 specification of its format is desired.--parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a-parseMaybe p s =-  case parse (p <* eof) "" s of-    Left  _ -> Nothing-    Right x -> Just x---- | The expression @parseTest p input@ applies the parser @p@ against 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 p input =-  case parse p "" input of-    Left  e -> putStr (parseErrorPretty 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').------ > 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 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.------ @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' 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)---- | 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' p s = do-  (Reply s' _ result) <- runParsecT p s-  case result of-    OK    x -> return (s', Right x)-    Error e -> return (s', Left  e)---- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser'--- are built upon this.--runParsecT :: Monad m-  => ParsecT e s m a -- ^ Parser to run-  -> State s       -- ^ Initial state-  -> 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)-        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)---- | 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 }--------------------------------------------------------------------------------- Instances of 'MonadParsec'--instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where-  failure us ps xs           = lift (failure us ps 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 ->-    (,s) . fst <$> lookAhead (m s)-  notFollowedBy (L.StateT m) = L.StateT $ \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 ->-    fixs s <$> observing (m s)-  eof                        = lift eof-  token test mt              = lift (token test mt)-  tokens e ts                = lift (tokens e ts)-  getParserState             = lift getParserState-  updateParserState f        = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where-  failure us ps xs           = lift (failure us ps xs)-  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)-  withRecovery r (S.StateT m) = S.StateT $ \s ->-    withRecovery (\e -> S.runStateT (r e) s) (m 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)-  getParserState             = lift getParserState-  updateParserState f        = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where-  failure us ps xs            = lift (failure us ps xs)-  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)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where-  failure us ps xs            = lift (failure us ps xs)-  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)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where-  failure us ps xs            = lift (failure us ps xs)-  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)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where-  failure us ps xs            = lift (failure us ps xs)-  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 ->-    withRecovery (\e -> L.runRWST (n e) r s) (m 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)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where-  failure us ps xs            = lift (failure us ps xs)-  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 ->-    withRecovery (\e -> S.runRWST (n e) r s) (m 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)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (IdentityT m) where-  failure us ps xs            = lift (failure us ps xs)-  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-  getParserState              = lift getParserState-  updateParserState f         = lift $ updateParserState f--fixs :: s -> Either a (b, s) -> (Either a b, s)-fixs s (Left a)       = (Left a, s)-fixs _ (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)-{-# INLINE fixs' #-}--------------------------------------------------------------------------------- Debugging---- | @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.------ 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.------ 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 5.1.0--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-      cok' x s' hs = flip trace (cok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)-      cerr' err s' = flip trace (cerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)-      eok' x s' hs = flip trace (eok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)-      eerr' err s' = flip trace (eerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)-  in unParser p s cok' cerr' eok' eerr'---- | A single piece of info to be rendered with 'dbgLog'.--data DbgItem s e a-  = DbgIn   [Token s]-  | DbgCOK  [Token s] a-  | DbgCERR [Token s] (ParseError (Token s) e)-  | DbgEOK  [Token s] a-  | DbgEERR [Token s] (ParseError (Token s) e)---- | Render a single piece of debugging info.--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---- | Pretty-print a list of tokens.--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 ++ " <…>"---- | Calculate number of consumed tokens given 'State' of parser before and--- after parsing.--streamDelta-  :: State s           -- ^ State of parser before consumption-  -> State s           -- ^ State of parser after consumption-  -> Word              -- ^ Number of consumed tokens-streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0---- | Extract a given number of tokens from the stream.--streamTake :: Stream s => Word -> s -> [Token s]-streamTake n s = genericTake n (unfold s)---- | A custom version of 'unfold' that matches signature of the 'uncons'--- method in the 'Stream' type class we use.--unfold :: Stream s => s -> [Token s]-unfold s = case uncons s of-  Nothing -> []-  Just (t, s') -> t : unfold s'
+ Text/Megaparsec/State.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :  Text.Megaparsec.State+-- Copyright   :  © 2015–present Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Definition of Megaparsec's 'State'.+--+-- @since 6.5.0+module Text.Megaparsec.State+  ( State (..),+    initialState,+    PosState (..),+    initialPosState,+  )+where++import Control.DeepSeq (NFData)+import Data.Data (Data)+import GHC.Generics+import {-# SOURCE #-} Text.Megaparsec.Error (ParseError)+import Text.Megaparsec.Pos++-- | This is the Megaparsec's state parametrized over stream type @s@ and+-- custom error component type @e@.+data State s e = State+  { -- | The rest of input to process+    stateInput :: s,+    -- | Number of processed tokens so far+    --+    -- @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)++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
@@ -0,0 +1,779 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :  Text.Megaparsec.Stream+-- Copyright   :  © 2015–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Megaparsec's input stream facilities.+--+-- You probably do not want to import this module directly because+-- "Text.Megaparsec" re-exports it anyway.+--+-- @since 6.0.0+module Text.Megaparsec.Stream+  ( Stream (..),+    ShareInput (..),+    NoShareInput (..),+    VisualStream (..),+    TraversableStream (..),+  )+where++import Data.Bifunctor (second)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.Char (chr)+import Data.Foldable (toList)+import Data.Kind (Type)+import qualified Data.List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe)+import Data.Proxy+import qualified Data.Sequence as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Word (Word8)+import Text.Megaparsec.Pos+import Text.Megaparsec.State+import qualified Text.Megaparsec.Unicode as Unicode++-- | Type class for inputs that can be consumed by the library.+--+-- Note that the 'Stream' instances for 'Text' and 'ByteString' (strict and+-- lazy) default to "input sharing" (see 'ShareInput', 'NoShareInput'). We plan+-- to move away from input sharing in a future major release; if you want to+-- retain the current behaviour and are concerned with maximum performance you+-- should consider using the 'ShareInput' wrapper explicitly.+--+-- __Note__: before the version /9.0.0/ the class included the methods from+-- 'VisualStream' and 'TraversableStream'.+class (Ord (Token s), Ord (Tokens s)) => Stream s where+  -- | Type of token in the stream.+  type Token s :: Type++  -- | Type of “chunk” of the stream.+  type Tokens s :: Type++  -- | Lift a single token to chunk of the stream. The default+  -- implementation is:+  --+  -- > tokenToChunk pxy = tokensToChunk pxy . pure+  --+  -- However for some types of stream there may be a more efficient way to+  -- lift.+  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+  -- is in terms of the more general 'chunkLength':+  --+  -- > chunkEmpty pxy ts = chunkLength pxy ts <= 0+  --+  -- However for many streams there may be a more efficient implementation.+  chunkEmpty :: Proxy s -> Tokens s -> Bool+  chunkEmpty pxy ts = chunkLength pxy ts <= 0++  -- | Extract a single token form the stream. Return 'Nothing' if the+  -- stream is empty.+  take1_ :: s -> Maybe (Token s, s)++  -- | @'takeN_' n s@ should try to extract a chunk of length @n@, or if the+  -- stream is too short, the rest of the stream. Valid implementation+  -- should follow the rules:+  --+  --     * If the requested length @n@ is 0 (or less), 'Nothing' should+  --       never be returned, instead @'Just' (\"\", s)@ should be returned,+  --       where @\"\"@ stands for the empty chunk, and @s@ is the original+  --       stream (second argument).+  --     * If the requested length is greater than 0 and the stream is+  --       empty, 'Nothing' should be returned indicating end of input.+  --     * 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+  -- predicate returns 'True'. Return the chunk and the rest of the stream.+  --+  -- For many types of streams, the method allows for significant+  -- performance improvements, although it is not strictly necessary from+  -- conceptual point of view.+  takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s)++-- | @since 9.0.0+instance (Ord a) => Stream [a] where+  type Token [a] = a+  type Tokens [a] = [a]+  tokenToChunk Proxy = pure+  tokensToChunk Proxy = id+  chunkToTokens Proxy = id+  chunkLength Proxy = length+  chunkEmpty Proxy = null+  take1_ [] = Nothing+  take1_ (t : ts) = Just (t, ts)+  takeN_ n s+    | n <= 0 = Just ([], s)+    | null s = Nothing+    | otherwise = Just (splitAt n s)+  takeWhile_ = span++-- | @since 9.0.0+instance (Ord a) => Stream (S.Seq a) where+  type Token (S.Seq a) = a+  type Tokens (S.Seq a) = S.Seq a+  tokenToChunk Proxy = pure+  tokensToChunk Proxy = S.fromList+  chunkToTokens Proxy = toList+  chunkLength Proxy = length+  chunkEmpty Proxy = null+  take1_ S.Empty = Nothing+  take1_ (t S.:<| ts) = Just (t, ts)+  takeN_ n s+    | n <= 0 = Just (S.empty, s)+    | null s = Nothing+    | otherwise = Just (S.splitAt n s)+  takeWhile_ = S.spanl++-- | This wrapper selects the input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). By input+-- sharing we mean that our parsers will use slices whenever possible to+-- avoid having to copy parts of the input. See also the documentation of+-- 'T.split'.+--+-- Note that using slices is in general faster than copying; on the other+-- hand it also has the potential for causing surprising memory leaks: if+-- any slice of the input survives in the output, holding on to the output+-- will force the entire input 'T.Text'/'B.ByteString' to stay in memory!+-- Even when using lazy 'TL.Text'/'BL.ByteString' we will hold on to whole+-- chunks at a time leading to to significantly worse memory residency in+-- some cases.+--+-- See 'NoShareInput' for a somewhat slower implementation that avoids this+-- memory leak scenario.+--+-- @since 9.3.0+newtype ShareInput a = ShareInput {unShareInput :: a}++instance Stream (ShareInput B.ByteString) where+  type Token (ShareInput B.ByteString) = Word8+  type Tokens (ShareInput B.ByteString) = B.ByteString+  tokenToChunk Proxy = B.singleton+  tokensToChunk Proxy = B.pack+  chunkToTokens Proxy = B.unpack+  chunkLength Proxy = B.length+  chunkEmpty Proxy = B.null+  take1_ (ShareInput s) = second ShareInput <$> B.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (B.empty, ShareInput s)+    | B.null s = Nothing+    | otherwise = Just . second ShareInput $ B.splitAt n s+  takeWhile_ p (ShareInput s) = second ShareInput $ B.span p s++instance Stream (ShareInput BL.ByteString) where+  type Token (ShareInput BL.ByteString) = Word8+  type Tokens (ShareInput BL.ByteString) = BL.ByteString+  tokenToChunk Proxy = BL.singleton+  tokensToChunk Proxy = BL.pack+  chunkToTokens Proxy = BL.unpack+  chunkLength Proxy = fromIntegral . BL.length+  chunkEmpty Proxy = BL.null+  take1_ (ShareInput s) = second ShareInput <$> BL.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (BL.empty, ShareInput s)+    | BL.null s = Nothing+    | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s+  takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s++instance Stream (ShareInput T.Text) where+  type Token (ShareInput T.Text) = Char+  type Tokens (ShareInput T.Text) = T.Text+  tokenToChunk Proxy = T.singleton+  tokensToChunk Proxy = T.pack+  chunkToTokens Proxy = T.unpack+  chunkLength Proxy = T.length+  chunkEmpty Proxy = T.null+  take1_ (ShareInput s) = second ShareInput <$> T.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (T.empty, ShareInput s)+    | T.null s = Nothing+    | otherwise = Just . second ShareInput $ T.splitAt n s+  takeWhile_ p (ShareInput s) = second ShareInput $ T.span p s++instance Stream (ShareInput TL.Text) where+  type Token (ShareInput TL.Text) = Char+  type Tokens (ShareInput TL.Text) = TL.Text+  tokenToChunk Proxy = TL.singleton+  tokensToChunk Proxy = TL.pack+  chunkToTokens Proxy = TL.unpack+  chunkLength Proxy = fromIntegral . TL.length+  chunkEmpty Proxy = TL.null+  take1_ (ShareInput s) = second ShareInput <$> TL.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (TL.empty, ShareInput s)+    | TL.null s = Nothing+    | otherwise = Just . second ShareInput $ TL.splitAt (fromIntegral n) s+  takeWhile_ p (ShareInput s) = second ShareInput $ TL.span p s++-- | This wrapper selects the no-input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). This means+-- that our parsers will create independent copies rather than using slices+-- of the input. See also the documentation of 'T.copy'.+--+-- More importantly, any parser output will be independent of the input, and+-- holding on to parts of the output will never prevent the input from being+-- garbage collected.+--+-- For maximum performance you might consider using 'ShareInput' instead,+-- but beware of its pitfalls!+--+-- @since 9.3.0+newtype NoShareInput a = NoShareInput {unNoShareInput :: a}++instance Stream (NoShareInput B.ByteString) where+  type Token (NoShareInput B.ByteString) = Word8+  type Tokens (NoShareInput B.ByteString) = B.ByteString+  tokenToChunk Proxy = B.singleton+  tokensToChunk Proxy = B.pack+  chunkToTokens Proxy = B.unpack+  chunkLength Proxy = B.length+  chunkEmpty Proxy = B.null+  take1_ (NoShareInput s) = second NoShareInput <$> B.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (B.empty, NoShareInput s)+    | B.null s = Nothing+    | otherwise =+        let (result, rest) = B.splitAt n s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = B.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = B.span p s+        -- Ditto.+        unSharedResult = B.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput BL.ByteString) where+  type Token (NoShareInput BL.ByteString) = Word8+  type Tokens (NoShareInput BL.ByteString) = BL.ByteString+  tokenToChunk Proxy = BL.singleton+  tokensToChunk Proxy = BL.pack+  chunkToTokens Proxy = BL.unpack+  chunkLength Proxy = fromIntegral . BL.length+  chunkEmpty Proxy = BL.null+  take1_ (NoShareInput s) = second NoShareInput <$> BL.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (BL.empty, NoShareInput s)+    | BL.null s = Nothing+    | otherwise =+        let (result, rest) = BL.splitAt (fromIntegral n) s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = BL.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = BL.span p s+        -- Ditto.+        unSharedResult = BL.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput T.Text) where+  type Token (NoShareInput T.Text) = Char+  type Tokens (NoShareInput T.Text) = T.Text+  tokenToChunk Proxy = T.singleton+  tokensToChunk Proxy = T.pack+  chunkToTokens Proxy = T.unpack+  chunkLength Proxy = T.length+  chunkEmpty Proxy = T.null+  take1_ (NoShareInput s) = second NoShareInput <$> T.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (T.empty, NoShareInput s)+    | T.null s = Nothing+    | otherwise =+        let (result, rest) = T.splitAt n s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = T.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = T.span p s+        unSharedResult = T.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput TL.Text) where+  type Token (NoShareInput TL.Text) = Char+  type Tokens (NoShareInput TL.Text) = TL.Text+  tokenToChunk Proxy = TL.singleton+  tokensToChunk Proxy = TL.pack+  chunkToTokens Proxy = TL.unpack+  chunkLength Proxy = fromIntegral . TL.length+  chunkEmpty Proxy = TL.null+  take1_ (NoShareInput s) = second NoShareInput <$> TL.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (TL.empty, NoShareInput s)+    | TL.null s = Nothing+    | otherwise =+        let (result, rest) = TL.splitAt (fromIntegral n) s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = tlCopy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = TL.span p s+        unSharedResult = tlCopy result+     in (unSharedResult, NoShareInput rest)++-- | Create an independent copy of a TL.Text, akin to BL.copy.+tlCopy :: TL.Text -> TL.Text+tlCopy = TL.fromStrict . T.copy . TL.toStrict+{-# INLINE tlCopy #-}++-- Since we are using @{-# LANGUAGE Safe #-}@ we can't use deriving via in+-- these cases.++instance Stream B.ByteString where+  type Token B.ByteString = Token (ShareInput B.ByteString)+  type Tokens B.ByteString = Tokens (ShareInput B.ByteString)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput B.ByteString))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput B.ByteString))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput B.ByteString))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput B.ByteString))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput B.ByteString))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream BL.ByteString where+  type Token BL.ByteString = Token (ShareInput BL.ByteString)+  type Tokens BL.ByteString = Tokens (ShareInput BL.ByteString)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput BL.ByteString))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream T.Text where+  type Token T.Text = Token (ShareInput T.Text)+  type Tokens T.Text = Tokens (ShareInput T.Text)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput T.Text))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput T.Text))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput T.Text))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput T.Text))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput T.Text))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream TL.Text where+  type Token TL.Text = Token (ShareInput TL.Text)+  type Tokens TL.Text = Tokens (ShareInput TL.Text)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput TL.Text))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput TL.Text))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput TL.Text))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput TL.Text))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput TL.Text))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++-- | Type class for inputs that can also be used for debugging.+--+-- @since 9.0.0+class (Stream s) => VisualStream s where+  -- | Pretty-print non-empty stream of tokens. This function is also used+  -- to print single tokens (represented as singleton lists).+  --+  -- @since 7.0.0+  showTokens :: Proxy s -> NonEmpty (Token s) -> String++  -- | Return the number of characters that a non-empty stream of tokens+  -- 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++-- | An internal helper state type combining a difference 'String' and an+-- unboxed 'SourcePos'.+data St = St {-# UNPACK #-} !SourcePos ShowS++-- | A helper definition to facilitate defining 'reachOffset' for various+-- stream types.+reachOffset' ::+  forall s.+  (Stream s) =>+  -- | How to split input stream at given offset+  (Int -> s -> (Tokens s, s)) ->+  -- | How to fold over input stream+  (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->+  -- | How to convert chunk of input stream into a 'String'+  (Tokens s -> String) ->+  -- | How to convert a token into a 'Char'+  (Token s -> Char) ->+  -- | Newline token and tab token+  (Token s, Token s) ->+  -- | Update column position for a token+  (Token s -> Pos -> Pos) ->+  -- | Offset to reach+  Int ->+  -- | Initial 'PosState' to use+  PosState s ->+  -- | Line at which 'SourcePos' is located, updated 'PosState'+  (Maybe String, PosState s)+reachOffset'+  splitAt'+  foldl''+  fromToks+  fromTok+  (newlineTok, tabTok)+  columnIncrement+  o+  PosState {..} =+    ( Just $ case expandTab pstateTabWidth+        . addPrefix+        . f+        . fromToks+        . fst+        $ takeWhile_ (/= newlineTok) post of+        "" -> "<empty line>"+        xs -> xs,+      PosState+        { pstateInput = post,+          pstateOffset = max pstateOffset o,+          pstateSourcePos = spos,+          pstateTabWidth = pstateTabWidth,+          pstateLinePrefix =+            if sameLine+              then -- NOTE We don't use difference lists here because it's+              -- desirable for 'PosState' to be an instance of 'Eq' and+              -- 'Show'. So we just do appending here. Fortunately several+              -- parse errors on the same line should be relatively rare.+                pstateLinePrefix ++ f ""+              else f ""+        }+    )+    where+      addPrefix xs =+        if sameLine+          then pstateLinePrefix ++ xs+          else xs+      sameLine = sourceLine spos == sourceLine pstateSourcePos+      (pre, post) = splitAt' (o - pstateOffset) pstateInput+      St spos f = foldl'' go (St pstateSourcePos id) pre+      go (St apos g) ch =+        let SourcePos n l c = apos+            c' = unPos c+            w = unPos pstateTabWidth+         in if+              | ch == newlineTok ->+                  St+                    (SourcePos n (l <> pos1) pos1)+                    id+              | ch == tabTok ->+                  St+                    (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)))+                    (g . (fromTok ch :))+              | otherwise ->+                  St+                    (SourcePos n l (columnIncrement ch c))+                    (g . (fromTok ch :))+{-# INLINE reachOffset' #-}++-- | Like 'reachOffset'' but for 'reachOffsetNoLine'.+reachOffsetNoLine' ::+  forall s.+  (Stream s) =>+  -- | How to split input stream at given offset+  (Int -> s -> (Tokens s, s)) ->+  -- | How to fold over input stream+  (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->+  -- | Newline token and tab token+  (Token s, Token s) ->+  -- | Update column position for a token+  (Token s -> Pos -> Pos) ->+  -- | Offset to reach+  Int ->+  -- | Initial 'PosState' to use+  PosState s ->+  -- | Updated 'PosState'+  PosState s+reachOffsetNoLine'+  splitAt'+  foldl''+  (newlineTok, tabTok)+  columnIncrement+  o+  PosState {..} =+    ( PosState+        { pstateInput = post,+          pstateOffset = max pstateOffset o,+          pstateSourcePos = spos,+          pstateTabWidth = pstateTabWidth,+          pstateLinePrefix = pstateLinePrefix+        }+    )+    where+      spos = foldl'' go pstateSourcePos pre+      (pre, post) = splitAt' (o - pstateOffset) pstateInput+      go (SourcePos n l c) ch =+        let c' = unPos c+            w = unPos pstateTabWidth+         in if+              | ch == newlineTok ->+                  SourcePos n (l <> pos1) pos1+              | ch == tabTok ->+                  SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))+              | otherwise ->+                  SourcePos n l (columnIncrement ch c)+{-# INLINE reachOffsetNoLine' #-}++-- | Like 'BL.splitAt' but accepts the index as an 'Int'.+splitAtBL :: Int -> BL.ByteString -> (BL.ByteString, BL.ByteString)+splitAtBL n = BL.splitAt (fromIntegral n)+{-# INLINE splitAtBL #-}++-- | Like 'TL.splitAt' but accepts the index as an 'Int'.+splitAtTL :: Int -> TL.Text -> (TL.Text, TL.Text)+splitAtTL n = TL.splitAt (fromIntegral n)+{-# INLINE splitAtTL #-}++-- | @stringPretty s@ returns pretty representation of string @s@. This is+-- used when printing string tokens in error messages.+stringPretty :: NonEmpty Char -> String+stringPretty (x :| []) = charPretty x+stringPretty ('\r' :| "\n") = "crlf newline"+stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\""+  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)++-- | 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/String.hs 
@@ -1,21 +0,0 @@--- |--- Module      :  Text.Megaparsec.String--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with 'String' as input stream.--module Text.Megaparsec.String (Parser) where--import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for 'String's.--type Parser = Parsec Dec String
− Text/Megaparsec/Text.hs 
@@ -1,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with strict 'Text'.--module Text.Megaparsec.Text (Parser) where--import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim-import Data.Text---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for strict 'Text'.--type Parser = Parsec Dec Text
− Text/Megaparsec/Text/Lazy.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text.Lazy--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with lazy 'Text'.--module Text.Megaparsec.Text.Lazy (Parser) where--import Data.Text.Lazy-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of the input--- stream by importing different “type modules”. This one is for lazy--- 'Text'.--type Parser = Parsec Dec Text
+ 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 
@@ -1,66 +0,0 @@-module Main (main) where--import Control.DeepSeq-import Control.Monad-import Text.Megaparsec-import Text.Megaparsec.String-import Weigh--main :: IO ()-main = mainWith $ do-  setColumns [Case, Allocated, GCs, Max]-  bparser "string"   manyAs (string . fst)-  bparser "string'"  manyAs (string' . fst)-  bparser "choice"   (const "b") (choice . fmap char . manyAsB . snd)-  bparser "many"     manyAs (const $ many (char 'a'))-  bparser "some"     manyAs (const $ some (char 'a'))-  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 "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 "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))-  bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))---- | Perform a series of measurements with the same parser.--bparser :: NFData a-  => String            -- ^ Name of the benchmark group-  -> (Int -> String)   -- ^ How to construct input-  -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input-  -> 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---- | The series of sizes to try as part of 'bparser'.--stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]--------------------------------------------------------------------------------- Helpers---- | Generate that many \'a\' characters.--manyAs :: Int -> String-manyAs n = replicate n 'a'---- | Like 'manyAs', but interspersed with \'b\'s.--manyAbs :: Int -> String-manyAbs n = take (if even n then n + 1 else n) (cycle "ab")---- | Like 'manyAs', but with a \'b\' added to the end.--manyAsB :: Int -> String-manyAsB n = replicate n 'a' ++ "b"---- | Like 'manyAbs', but ends in a \'b\'.--manyAbs' :: Int -> String-manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
− bench-speed/Main.hs 
@@ -1,65 +0,0 @@-module Main (main) where--import Control.DeepSeq-import Criterion.Main-import Text.Megaparsec-import Text.Megaparsec.String--main :: IO ()-main = defaultMain-  [ bparser "string"   manyAs (string . fst)-  , bparser "string'"  manyAs (string' . fst)-  , bparser "choice"   (const "b") (choice . fmap char . manyAsB . snd)-  , bparser "many"     manyAs (const $ many (char 'a'))-  , bparser "some"     manyAs (const $ some (char 'a'))-  , 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 "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 "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))-  , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))-  ]---- | Perform a series to measurements with the same parser.--bparser :: NFData a-  => String            -- ^ Name of the benchmark group-  -> (Int -> String)   -- ^ How to construct input-  -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input-  -> Benchmark         -- ^ The 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---- | The series of sizes to try as part of 'bparser'.--stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]--------------------------------------------------------------------------------- Helpers---- | Generate that many \'a\' characters.--manyAs :: Int -> String-manyAs n = replicate n 'a'---- | Like 'manyAs', but with a \'b\' added to the end.--manyAsB :: Int -> String-manyAsB n = replicate n 'a' ++ "b"---- | Like 'manyAs', but interspersed with \'b\'s and ends in a \'a\'.--manyAbs :: Int -> String-manyAbs n = take (if even n then n + 1 else n) (cycle "ab")---- | Like 'manyAbs', but ends in a \'b\'.--manyAbs' :: Int -> String-manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
+ bench/memory/Main.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Control.DeepSeq+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as E+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void+import Text.Megaparsec+import qualified Text.Megaparsec.Byte.Binary as Binary+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+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 "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)++  forM_ stdSeries $ \n ->+    bbundle "single error" n [n]++  bbundle "2 errors" 1000 [1, 1000]+  bbundle "4 errors" 1000 [1, 500, 1000]+  bbundle "100 errors" 1000 [10, 20 .. 1000]++  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++-- | 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]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.+manyAs :: Int -> Text+manyAs n = T.replicate n "a"++-- | 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
@@ -0,0 +1,221 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Control.DeepSeq+import Criterion.Main+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as E+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void+import Text.Megaparsec+import qualified Text.Megaparsec.Byte.Binary as Binary+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++-- | 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),+      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) =>+  -- | 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++-- | 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]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.+manyAs :: Int -> Text+manyAs n = T.replicate n "a"++-- | 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,141 +1,127 @@-name:                 megaparsec-version:              5.3.1-cabal-version:        >= 1.10-tested-with:          GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.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 industrial-strength monadic parser combinator library. Megaparsec-  is a fork of Parsec library originally written by Daan Leijen.+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:      QuickCheck   >= 2.7   && < 2.11-                    , base         >= 4.7   && < 5.0-                    , bytestring   >= 0.2   && < 0.11-                    , containers   >= 0.5   && < 0.6-                    , deepseq      >= 1.3   && < 1.5-                    , exceptions   >= 0.6   && < 0.9-                    , mtl          >= 2.0   && < 3.0-                    , scientific   >= 0.3.1 && < 0.4-                    , text         >= 0.2   && < 1.3-                    , transformers >= 0.4   && < 0.6+    exposed-modules:+        Text.Megaparsec+        Text.Megaparsec.Byte+        Text.Megaparsec.Byte.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 -  if !impl(ghc >= 8.0)-    -- packages providing modules that moved into base-4.9.0.0-    build-depends:    fail         == 4.9.*-                    , semigroups   == 0.18.*+    other-modules:+        Text.Megaparsec.Class+        Text.Megaparsec.Common+        Text.Megaparsec.Lexer -  if !impl(ghc >= 7.8)-    build-depends:    tagged       == 0.8.*+    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 -  exposed-modules:    Text.Megaparsec-                    , Text.Megaparsec.ByteString-                    , Text.Megaparsec.ByteString.Lazy-                    , Text.Megaparsec.Char-                    , Text.Megaparsec.Combinator-                    , Text.Megaparsec.Error-                    , Text.Megaparsec.Expr-                    , Text.Megaparsec.Lexer-                    , Text.Megaparsec.Perm-                    , Text.Megaparsec.Pos-                    , Text.Megaparsec.Prim-                    , Text.Megaparsec.String-                    , Text.Megaparsec.Text-                    , Text.Megaparsec.Text.Lazy-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  default-language:   Haskell2010+    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -test-suite tests-  main-is:            Spec.hs-  hs-source-dirs:     tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  other-modules:      Test.Hspec.Megaparsec-                    , Test.Hspec.Megaparsec.AdHoc-                    , Text.Megaparsec.CharSpec-                    , Text.Megaparsec.CombinatorSpec-                    , Text.Megaparsec.ErrorSpec-                    , Text.Megaparsec.ExprSpec-                    , Text.Megaparsec.LexerSpec-                    , Text.Megaparsec.PermSpec-                    , Text.Megaparsec.PosSpec-                    , Text.Megaparsec.PrimSpec-  build-depends:      QuickCheck   >= 2.7   && < 2.11-                    , base         >= 4.7   && < 5.0-                    , bytestring   >= 0.2   && < 0.11-                    , containers   >= 0.5   && < 0.6-                    , exceptions   >= 0.6   && < 0.9-                    , 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+    else+        ghc-options: -O2 -Wall -  if !impl(ghc >= 8.0)-    -- packages providing modules that moved into base-4.9.0.0-    build-depends:    semigroups     == 0.18.*+    if impl(ghc >=9.8)+        ghc-options: -Wno-x-partial -  if !impl(ghc >= 7.8)-    build-depends:    tagged       == 0.8.*+benchmark bench-speed+    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 -  default-language:   Haskell2010+    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -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.3-                    , deepseq      >= 1.3  && < 1.5-                    , megaparsec-  if flag(dev)-    ghc-options:      -O2 -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  default-language:   Haskell2010+    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-                    , weigh        >= 0.0.4-  if flag(dev)-    ghc-options:      -O2 -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  default-language:   Haskell2010+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   bench/memory+    default-language: Haskell2010+    build-depends:+        base >=4.18 && <5,+        bytestring >=0.2 && <0.13,+        containers >=0.5 && <0.9,+        deepseq >=1.3 && <1.6,+        megaparsec,+        text >=0.2 && <2.2,+        weigh >=0.0.4++    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages++    else+        ghc-options: -O2 -Wall
− tests/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− tests/Test/Hspec/Megaparsec.hs 
@@ -1,387 +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 BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}--module Test.Hspec.Megaparsec-  ( -- * Basic expectations-    shouldParse-  , parseSatisfies-  , shouldSucceedOn-  , shouldFailOn-    -- * Testing of error messages-  , shouldFailWith-    -- * Error message construction-    -- $errmsg-  , err-  , posI-  , posN-  , EC-  , utok-  , utoks-  , ulabel-  , ueof-  , etok-  , etoks-  , elabel-  , eeof-  , cstm-    -- * Incremental parsing-  , failsLeaving-  , succeedsLeaving-  , initialState )-where--import Control.Monad (unless)-import Data.Data (Data)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Proxy-import Data.Semigroup-import Data.Set (Set)-import Data.Typeable (Typeable)-import GHC.Generics-import Test.Hspec.Expectations-import Text.Megaparsec-import Text.Megaparsec.Pos (defaultTabWidth)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E--------------------------------------------------------------------------------- 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--------------------------------------------------------------------------------- Error message construction---- $errmsg------ When you wish to test error message on failure, the need to construct a--- error message for comparison arises. These helpers allow to construct--- virtually any sort of error message easily.---- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To--- create source position, two helpers are available: 'posI' and 'posN'.--- @'EC' t e@ is a monoid and can be built from primitives provided by this--- module, see below.------ @since 0.3.0--err-  :: NonEmpty SourcePos -- ^ 'ParseError' position-  -> EC t e             -- ^ Error components-  -> ParseError t e     -- ^ Resulting 'ParseError'-err pos (EC u e c) = ParseError pos u e c---- | Initial source position with empty file name.------ @since 0.3.0--posI :: NonEmpty SourcePos-posI = initialPos "" :| []---- | @posN n s@ returns source position achieved by applying 'updatePos'--- method corresponding to type of stream @s@ @n@ times.------ @since 0.3.0--posN :: forall s n. (Stream s, Integral n)-  => n-  -> s-  -> NonEmpty SourcePos-posN n see = f (initialPos "") see n :| []-  where-    f p s !i =-      if i > 0-        then case uncons s of-          Nothing -> p-          Just (t,s') ->-            let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t-            in f p' s' (i - 1)-        else p---- | Auxiliary type for construction of 'ParseError's. Note that it's a--- monoid.------ @since 0.3.0--data EC t e = EC-  { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items-  , ecExpected   :: Set (ErrorItem t) -- ^ Expected items-  , _ecCustom    :: Set e             -- ^ Custom items-  } deriving (Eq, Data, Typeable, Generic)--instance (Ord t, Ord e) => Semigroup (EC t e) where-  (EC u0 e0 c0) <> (EC u1 e1 c1) =-    EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1)--instance (Ord t, Ord e) => Monoid (EC t e) where-  mempty  = EC E.empty E.empty E.empty-  mappend = (<>)---- | Construct an “unexpected token” error component.------ @since 0.3.0--utok :: (Ord t, Ord e) => t -> EC t e-utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t }---- | Construct an “unexpected tokens” error component. Empty string produces--- 'EndOfInput'.------ @since 0.3.0--utoks :: (Ord t, Ord e) => [t] -> EC t e-utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t }---- | Construct an “unexpected label” error component. Do not use with empty--- strings (for empty strings it's bottom).------ @since 0.3.0--ulabel :: (Ord t, Ord e) => String -> EC t e-ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l }---- | Construct an “unexpected end of input” error component.------ @since 0.3.0--ueof :: (Ord t, Ord e) => EC t e-ueof = mempty { ecUnexpected = E.singleton EndOfInput }---- | Construct an “expected token” error component.------ @since 0.3.0--etok :: (Ord t, Ord e) => t -> EC t e-etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t }---- | Construct an “expected tokens” error component. Empty string produces--- 'EndOfInput'.------ @since 0.3.0--etoks :: (Ord t, Ord e) => [t] -> EC t e-etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t }---- | Construct an “expected label” error component. Do not use with empty--- strings.------ @since 0.3.0--elabel :: (Ord t, Ord e) => String -> EC t e-elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l }---- | Construct an “expected end of input” error component.------ @since 0.3.0--eeof :: (Ord t, Ord e) => EC t e-eeof = mempty { ecExpected = E.singleton EndOfInput }---- | Construct a custom error component.------ @since 0.3.0--cstm :: e -> EC t e-cstm e = EC E.empty E.empty (E.singleton e)--------------------------------------------------------------------------------- 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 "" :| []-#if MIN_VERSION_megaparsec(5,2,0)-  , stateTokensProcessed = 0-#endif-  , 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---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}---- | Construct appropriate 'ErrorItem' representation for given token--- stream. Empty string produces 'EndOfInput'.--canonicalizeTokens :: [t] -> ErrorItem t-canonicalizeTokens ts =-  case NE.nonEmpty ts of-    Nothing -> EndOfInput-    Just xs -> Tokens xs
− tests/Test/Hspec/Megaparsec/AdHoc.hs 
@@ -1,173 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}--module Test.Hspec.Megaparsec.AdHoc-  ( -- * Helpers to run parsers-    prs-  , prs'-  , prs_-  , grs-  , grs'-    -- * Working with source position-  , updatePosString-  , pos1-  , nes-    -- * Other-  , abcRow-  , toFirstMismatch )-where--import Control.Monad-import Control.Monad.Reader-import Control.Monad.Trans.Identity-import Data.Foldable (foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Test.Hspec-import Test.Hspec.Megaparsec-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-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--#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-  :: Parsec Dec String a -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Dec) a -- ^ Result of parsing-prs p = parse p ""-{-# INLINE prs #-}---- | Just like 'prs', but allows to inspect final state of the parser.--prs'-  :: Parsec Dec String a -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing-prs' p s = runParser' p (initialState s)-{-# INLINE prs' #-}---- | Just like 'prs', but forces the parser to consume all input by adding--- 'eof':------ > prs_ p = parse (p <* eof) ""--prs_-  :: Parsec Dec String a -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Dec) a -- ^ Result of parsing-prs_ p = parse (p <* eof) ""-{-# INLINE prs_ #-}---- | Just like 'prs', but interprets given parser as various monads (tries--- all supported monads transformers in turn).--grs-  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> (Either (ParseError Char Dec) 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' as 'prs'' to 'prs'.--grs'-  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> ((State String, Either (ParseError Char Dec) 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 w = foldl' f-  where f p t = snd (defaultUpdatePos w p t)---- | Position with minimal value.--pos1 :: Pos-pos1 = unsafePos 1---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}--------------------------------------------------------------------------------- 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))
− tests/Text/Megaparsec/CharSpec.hs 
@@ -1,426 +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.Char-import Text.Megaparsec.Error-import Text.Megaparsec.Prim--#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 <> utok '\r' <> 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-            (utok ch <> 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 it 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 "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-    context "when stream begins with the character specified as argument" $-      it "parses the character" $-        property $ \ch s -> 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 -> 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 -> 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 "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 "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)-              sl  = toLower ch : s-              su  = toUpper ch : s-          prs  (oneOf' chs) sl `shouldParse`     toLower ch-          prs  (oneOf' chs) su `shouldParse`     toUpper ch-          prs' (oneOf' chs) sl `succeedsLeaving` s-          prs' (oneOf' chs) su `succeedsLeaving` s-    context "when stream does not begin with any of specified characters" $-      it "signals correct parse error" $-        property $ \chs ch s  -> ch `notElemi` (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 "noneOf'" $ do-    context "when stream does not begin with any of specified characters" $-      it "parses the character" $-        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do-          let sl  = toLower ch : s-              su  = toUpper ch : s-          prs  (noneOf' chs) sl `shouldParse`     toLower ch-          prs  (noneOf' chs) su `shouldParse`     toUpper ch-          prs' (noneOf' chs) sl `succeedsLeaving` s-          prs' (noneOf' chs) su `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 n = length (takeWhile (uncurry (==)) (zip str s)) + 1-              common = take n s-          prs  (string str) s `shouldFailWith` err posI (utoks common <> 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 n = length (takeWhile (uncurry casei) (zip str s)) + 1-              common = take n s-          prs  (string' str) s `shouldFailWith` err posI (utoks common <> etoks str)--------------------------------------------------------------------------------- Helpers--checkStrLit :: String -> String -> Parsec Dec String 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-       prs  p s' `shouldFailWith` err posI (utok ch <> 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) -> Parsec Dec String 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 -> Parsec Dec String 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 does not begin with " ++ name) $-  --   it "signals correct parse error" $-  --     property $ \ch s -> ch `notElem` tchs ==> 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)---- | 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---- | Case-insensitive 'elem'.--elemi :: Char -> String -> Bool-elemi c = any (casei c)---- | Case-insensitive 'notElem'.--notElemi :: Char -> String -> Bool-notElemi c = not . elemi c---- | 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/CombinatorSpec.hs 
@@ -1,228 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--module Text.Megaparsec.CombinatorSpec (spec) where--import Control.Applicative-import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)-import Data.Monoid-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char-import Text.Megaparsec.Combinator--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 [post !! b]) )-      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" . 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--  describe "count'" . 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)--  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" . 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'--  describe "endBy1" . 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'--  describe "manyTill" . 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)--  describe "someTill" . 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)--  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" . 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)--  describe "sepBy1" . 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)--  describe "sepEndBy" . 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)--  describe "sepEndBy1" . 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)--  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--------------------------------------------------------------------------------- Helpers--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0
− tests/Text/Megaparsec/ErrorSpec.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.Megaparsec.ErrorSpec (spec) where--import Data.Char (isControl, isSpace)-import Data.Function (on)-import Data.List (isInfixOf, isSuffixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid-import Data.Set (Set)-import Test.Hspec-import Test.QuickCheck-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-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--type PE = ParseError Char Dec--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)-    it "merges unexpected items correctly" $-      property (checkMergedItems errorUnexpected)-    it "merges expected items correctly" $-      property (checkMergedItems errorExpected)-    it "merges custom items correctly" $-      property (checkMergedItems errorCustom)--  describe "showTokens (Char instance)" $ do-    let 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 (control character)")-    it "shows start of heading correctly"-      (f "\SOH" "start of heading (control character)")-    it "shows start of text correctly"-      (f "\STX" "start of text (control character)")-    it "shows end of text correctly"-      (f "\ETX" "end of text (control character)")-    it "shows end of transmission correctly"-      (f "\EOT" "end of transmission (control character)")-    it "shows enquiry correctly"-      (f "\ENQ" "enquiry (control character)")-    it "shows acknowledge correctly"-      (f "\ACK" "acknowledge (control character)")-    it "shows bell correctly"-      (f "\BEL" "bell (control character)")-    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 (control character)")-    it "shows carriage return correctly"-      (f "\r" "carriage return")-    it "shows shift out correctly"-      (f "\SO" "shift out (control character)")-    it "shows shift in correctly"-      (f "\SI" "shift in (control character)")-    it "shows data link escape correctly"-      (f "\DLE" "data link escape (control character)")-    it "shows device control one correctly"-      (f "\DC1" "device control one (control character)")-    it "shows device control two correctly"-      (f "\DC2" "device control two (control character)")-    it "shows device control three correctly"-      (f "\DC3" "device control three (control character)")-    it "shows device control four correctly"-      (f "\DC4" "device control four (control character)")-    it "shows negative acknowledge correctly"-      (f "\NAK" "negative acknowledge (control character)")-    it "shows synchronous idle correctly"-      (f "\SYN" "synchronous idle (control character)")-    it "shows end of transmission block correctly"-      (f "\ETB" "end of transmission block (control character)")-    it "shows cancel correctly"-      (f "\CAN" "cancel (control character)")-    it "shows end of medium correctly"-      (f "\EM"  "end of medium (control character)")-    it "shows substitute correctly"-      (f "\SUB" "substitute (control character)")-    it "shows escape correctly"-      (f "\ESC" "escape (control character)")-    it "shows file separator correctly"-      (f "\FS"  "file separator (control character)")-    it "shows group separator correctly"-      (f "\GS"  "group separator (control character)")-    it "shows record separator correctly"-      (f "\RS"  "record separator (control character)")-    it "shows unit separator correctly"-      (f "\US"  "unit separator (control character)")-    it "shows delete correctly"-      (f "\DEL" "delete (control character)")-    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 ->-        (length str > 1) && (str /= "\r\n") ==>-          showTokens (NE.fromList str) === ("\"" ++ str ++"\"")--  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" $-      property (contains errorUnexpected showErrorComponent)-    it "result contains representation of expected items" $-      property (contains errorExpected showErrorComponent)-    it "result contains representation of custom items" $-      property (contains errorCustom showErrorComponent)--  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 unknown ParseError correctly" $-      parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown 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--checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property-checkMergedItems f e1 e2 = f (e1 <> e2) === r-  where r = case (compare `on` errorPos) e1 e2 of-              LT -> f e2-              EQ -> (E.union `on` f) e1 e2-              GT -> f e1--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 Control.Applicative (some, (<|>))-import Data.Monoid ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Expr-import Text.Megaparsec.Prim--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)-#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-            n = 1 :: Integer-        prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term")-        prs p "(" `shouldFailWith` err (posN n "(") (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 :: (MonadParsec e s m, Token s ~ Char) => m a -> m a-lexeme p = p <* hidden space--symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String-symbol = lexeme . string--parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a-parens = between (symbol "(") (symbol ")")--integer :: (MonadParsec e s m, Token s ~ Char) => m 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 :: (MonadParsec e s m, Token s ~ Char) => m Node-expr = makeExprParser term table--term :: (MonadParsec e s m, Token s ~ Char) => m Node-term = parens expr <|> (Val <$> integer) <?> "term"--table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]]-table = [ [ Prefix  (symbol "-" *> pure Neg)-          , Postfix (symbol "!" *> pure Fac)-          , InfixN  (symbol "%" *> pure Mod) ]-        , [ InfixR  (symbol "^" *> pure Exp) ]-        , [ InfixL  (symbol "*" *> pure Pro)-          , InfixL  (symbol "/" *> pure Div) ]-        , [ InfixL  (symbol "+" *> pure Sum)-          , InfixL  (symbol "-" *> pure Sub)] ]
− tests/Text/Megaparsec/LexerSpec.hs 
@@ -1,490 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf       #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE TypeFamilies     #-}--module Text.Megaparsec.LexerSpec (spec) where--import Control.Applicative-import Control.Monad (void)-import Data.Char hiding (ord)-import Data.List (isInfixOf)-import Data.Maybe-import Data.Monoid ((<>))-import Data.Scientific (fromFloatDigits)-import Numeric (showInt, showHex, showOct)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Error-import Text.Megaparsec.Lexer-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String-import qualified Text.Megaparsec.Char as C--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 (toUpper <$> y)-              y = takeWhile (not . isSpace) s-          prs  p s `shouldParse` y-          prs' p s `succeedsLeaving` ""--  describe "skipLineComment" $-    context "when there is no newline at the end of line" $-      it "is picked up successfully" $ do-        let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof-            s = "  // this line comment doesn't have a newline at the end "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""--  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` err 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` err posI (ii GT pos1 col0)-             | col1 /= col0 ->-               prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)-             | col2 <= col0 ->-               prs p s `shouldFailWith` err (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` err (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  = unsafePos . 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'  = unsafePos (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`-               err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)-             | col2 <= col1 -> prs p s `shouldFailWith`-               err (posN (getIndent l2 + g 2) s) (ii GT col1 col2)-             | col3 == col2 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utok (head 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`-               err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)-             | col3 > col1 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)-             | col4 <= col3 -> prs p s `shouldFailWith`-               err (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` ""--  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`-               err (posN (getIndent l1 + g 1) s) (ii GT col0 col1)-             | end1 && col2 <= col0 -> prs p s `shouldFailWith`-               err (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 "integer" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = 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 = 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 integer "" `shouldFailWith`-          err posI (ueof <> elabel "integer")--  describe "decimal" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = decimal-              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-              s = a : as-          prs  p s `shouldFailWith` err posI (utok a <> elabel "decimal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs decimal "" `shouldFailWith`-          err posI (ueof <> elabel "decimal integer")--  describe "hexadecimal" $ do-    context "when stream begins with hexadecimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = hexadecimal-              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-              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 "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")--  describe "octal" $ do-    context "when stream begins with octal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = octal-              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-              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 "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")--  describe "float" $ do-    context "when stream begins with a float" $-      it "parses it" $-        property $ \n' -> do-          let p = float-              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-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "floating point number")-          prs' p s `failsLeaving` s-    context "when stream begins with a decimal number" $-      it "signals correct parse error" $-        property $ \n' -> do-          let p = float-              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 stream is empty" $-      it "signals correct parse error" $-        prs float "" `shouldFailWith`-          err posI (ueof <> elabel "floating point number")-    context "when there is float with exponent without explicit sign" $-      it "parses it all right" $ do-        let p = float-            s = "123e3"-        prs  p s `shouldParse` 123e3-        prs' p s `succeedsLeaving` ""--  describe "number" $ do-    context "when stream begins with a number" $-      it "parses it" $-        property $ \n' -> do-          let p = number-              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 stream is empty" $-      it "signals correct parse error" $-        prs number "" `shouldFailWith`-          err posI (ueof <> elabel "number")--  describe "signed" $ do-    context "with integer" $-      it "parses signed integers" $-        property $ \n -> do-          let p = signed (hidden C.space) integer-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with float" $-      it "parses signed floats" $-        property $ \n -> do-          let p = signed (hidden C.space) float-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with number" $-      it "parses singed numbers" $-        property $ \n -> do-          let p = signed (hidden C.space) number-              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 = signed (hidden C.space) integer-              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 = signed (hidden C.space) integer-              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 = signed (hidden C.space) integer-            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 $ C.oneOf " \t") empty empty--scn :: Parser ()-scn = space (void C.spaceChar) 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 -> EC Char Dec-ii ord ref actual = cstm (DecIndentation ord ref actual)
− tests/Text/Megaparsec/PermSpec.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--module Text.Megaparsec.PermSpec (spec) where--import Control.Applicative-import Data.List (nub, elemIndices)-import Data.Monoid-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char-import Text.Megaparsec.Lexer (integer)-import Text.Megaparsec.Perm--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 <$$> 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, integer))-          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,99 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.Megaparsec.PosSpec (spec) where--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--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif--spec :: Spec-spec = do--  describe "mkPos" $ do-    context "when the argument is 0" $-      it "throws InvalidPosException" $-        mkPos (0 :: Word) `shouldThrow` (== InvalidPosException)-    context "when the argument is not 0" $-      it "returns Pos with the given value" $-        property $ \n ->-          (n > 0) ==> (mkPos n >>= shouldBe n . unPos)--  describe "unsafePos" $-    context "when the argument is a positive integer" $-      it "returns Pos with the given value" $-        property $ \n ->-          (n > 0) ==> (unPos (unsafePos n) === 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 === unsafePos (unPos x + unPos y) .&&.-        unPos (x <> y) === unPos x + unPos y--  describe "initialPos" $-    it "consturcts initial position correctly" $-      property $ \path ->-        let x = initialPos path-        in sourceName   x === path        .&&.-           sourceLine   x === unsafePos 1 .&&.-           sourceColumn x === unsafePos 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--  describe "defaultUpdatePos" $ do-    it "returns actual position unchanged" $-      property $ \w pos ch ->-        fst (defaultUpdatePos w pos ch) === pos-    it "does not change file name" $-      property $ \w pos ch ->-        (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos-    context "when given newline character" $-      it "increments line number" $-        property $ \w pos ->-          (sourceLine . snd) (defaultUpdatePos w pos '\n')-            === (sourceLine pos <> pos1)-    context "when given tab character" $-      it "shits column number to next tab position" $-        property $ \w pos ->-          let c  = sourceColumn pos-              c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t')-          in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0)-    context "when given character other than newline or tab" $-      it "increments column number by one" $-        property $ \w pos ch ->-          (ch /= '\n' && ch /= '\t') ==>-          (sourceColumn . snd) (defaultUpdatePos w pos ch)-            === (sourceColumn pos <> pos1)
− tests/Text/Megaparsec/PrimSpec.hs 
@@ -1,1535 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Text.Megaparsec.PrimSpec (spec) where--import Control.Applicative-import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (toUpper, chr)-import Data.Foldable (asum, concat)-import Data.Function (on)-import Data.List (isPrefixOf, foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, listToMaybe, isJust)-import Data.Monoid-import Data.Proxy-import Data.Word (Word8)-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.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String-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.Char8       as B-import qualified Data.ByteString.Lazy.Char8  as BL-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.Text.Lazy              as TL--#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 "non-String instances of Stream" $ do-    context "lazy ByteString" $ do-      it "unconses correctly" $-        property $ \ch' n -> do-          let p  = many (char ch) :: Parsec Dec BL.ByteString String-              s  = replicate (getNonNegative n) ch-              ch = byteToChar ch'-          parse p "" (BL.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "strict ByteString" $ do-      it "unconses correctly" $-        property $ \ch' n -> do-          let p  = many (char ch) :: Parsec Dec B.ByteString String-              s  = replicate (getNonNegative n) ch-              ch = byteToChar ch'-          parse p "" (B.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "lazy Text" $ do-      it "unconses correctly" $-        property $ \ch n -> do-          let p = many (char ch) :: Parsec Dec TL.Text String-              s = replicate (getNonNegative n) ch-          parse p "" (TL.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "strict Text" $ do-      it "unconses correctly" $-        property $ \ch n -> do-          let p = many (char ch) :: Parsec Dec T.Text String-              s = replicate (getNonNegative n) ch-          parse p "" (T.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch--  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 is stream correctly" $-        property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do-          let p = tokens compareTokens ts :: CustomParser [Span]-              compareTokens x y = spanBody x == spanBody y-              updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth-              il = length . takeWhile id $ zipWith compareTokens stateInput ts-              tl = length ts-              consumed = take il stateInput-              (apos, npos) =-                let (pos:|z) = statePos-                in ( spanStart (head stateInput) :| z-                   , foldl' (\q t -> snd (updatePos' q t)) 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 (length ts) stateInput }-               , Right consumed )-             | otherwise -> runParser' p st `shouldBe`-               ( st { statePos = apos }-               , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) )--    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 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-                  z0' = toFirstMismatch (==) s0 s-                  z1' = toFirstMismatch (==) s1 s-              prs  p s `shouldFailWith` err posI-                (etoks s0 <>-                 etoks s1 <>-                 (if null s then ueof else mempty) <>-                 (if null z0' then mempty else utoks z0') <>-                 (if null z1' then mempty else utoks z1'))-      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 Dec) ())-                v = runParserT p "" ""-            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 Dec String ()-        prs p "" `shouldFailWith` err posI (cstm (DecFail 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` err posI (cstm $ DecFail msg)-          prs' p s `failsLeaving` s--  describe "ParsecT MonadIO instance" $-    it "liftIO works" $-      property $ \n -> do-        let p = liftIO (return n) :: ParsecT Dec String IO Integer-        runParserT p "" "" `shouldReturn` Right n--  describe "ParsecT MonadReader instance" $ do--    describe "ask" $-      it "returns correct value of context" $-        property $ \n -> do-          let p = ask :: ParsecT Dec 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 Dec 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 Dec 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 Dec 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 Dec String (Cont (Either (ParseError Char Dec) 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 Dec 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 Dec 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 "unexpected" $-      it "signals correct parse error" $-        property $ \item -> do-          let p :: MonadParsec Dec String m => m ()-              p = void (unexpected item)-          grs p "" (`shouldFailWith` ParseError-            { errorPos        = posI-            , errorUnexpected = E.singleton item-            , errorExpected   = E.empty-            , errorCustom     = E.empty })--    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 e0 e1 -> do-            let p :: Parser Int-                p = region f $ failure-                  (errorUnexpected e0)-                  (errorExpected   e0)-                  (errorCustom     e0)-                f x = ParseError-                  { errorPos        = ((G.<>)  `on` errorPos)        x e1-                  , errorUnexpected = (E.union `on` errorUnexpected) x e1-                  , errorExpected   = (E.union `on` errorExpected)   x e1-                  , errorCustom     = (E.union `on` errorCustom)     x e1 }-                r = ParseError-                  { errorPos        = finalPos-                  , errorUnexpected = (E.union `on` errorUnexpected) e0 e1-                  , errorExpected   = (E.union `on` errorExpected)   e0 e1-                  , errorCustom     = (E.union `on` errorCustom)     e0 e1 }-                finalPos = statePos st G.<> errorPos e1-            runParser' p st `shouldBe` (st { statePos = finalPos }, Left r)--    describe "failure" $-      it "signals correct parse error" $-        property $ \us ps xs -> do-          let p :: MonadParsec Dec String m => m ()-              p = void (failure us ps xs)-          grs p "" (`shouldFailWith` ParseError-            { errorPos        = posI-            , errorUnexpected = us-            , errorExpected   = ps-            , errorCustom     = 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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" $-        it "backtracks, it appears as if the parser has not consumed anything" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Dec 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)-      context "when inner parser succeeds without consuming" $-        it "try has no effect" $-          property $ \a -> do-            let p :: MonadParsec Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 'a' <> etok 'c'))-                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'a' <> 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) 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 Dec String m => m (Either (ParseError Char Dec) ())-                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 Dec String m => m (Either (ParseError Char Dec) 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 = E.singleton (Tokens $ nes x)-          testChar a x = if x == a then Right x else Left (f x, f a, E.empty)-      context "when supplied predicate is satisfied" $-        it "succeeds" $-          property $ \a as mtok -> do-            let p :: MonadParsec Dec 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 Dec String m => m Char-                p = token (testChar b) mtok-                s = a : as-            grs  p s (`shouldFailWith` ParseError-              { errorPos        = posI-              , errorUnexpected = E.singleton (Tokens $ nes a)-              , errorExpected   = E.singleton (Tokens $ nes b)-              , errorCustom     = E.empty })-            grs' p s (`failsLeaving` s)-      context "when stream is empty" $-        it "signals correct parse error" $-          property $ \a mtok -> do-            let p :: MonadParsec Dec String m => m Char-                p = token (testChar a) mtok-            grs p "" (`shouldFailWith` ParseError-              { errorPos        = posI-              , errorUnexpected = E.singleton EndOfInput-              , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtok-              , errorCustom     = E.empty })--    describe "tokens" $ do-      context "when stream is prefixed with given string" $-        it "parses the string" $-          property $ \str s -> do-            let p :: MonadParsec Dec 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 Dec String m => m String-                p = tokens (==) str-                z = toFirstMismatch (==) str s-            grs  p s (`shouldFailWith` err posI (utoks z <> etoks str))-            grs' 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 Dec 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--byteToChar :: Word8 -> Char-byteToChar = chr . fromIntegral---- | 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-  uncons [] = Nothing-  uncons (t:ts) = Just (t, ts)-  updatePos _ _ _ (Span start end _) = (start, end)--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)--type CustomParser = Parsec Dec [Span]--pSpan :: Span -> CustomParser Span-pSpan span = token testToken (Just span)-  where-    f = E.singleton . Tokens . nes-    testToken x =-      if spanBody x == spanBody span-        then Right span-        else Left (f x, f span , E.empty)--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 Dec) String)-emulateStrParsing st@(State i (pos:|z) tp w) s =-  if l == length s-    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 + 1) i)))-  where l = length (takeWhile id $ zipWith (==) s i)