packages feed

megaparsec 5.0.1 → 9.8.1

raw patch · 55 files changed

Files

− AUTHORS.md 
@@ -1,51 +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
CHANGELOG.md view
@@ -1,3 +1,675 @@+*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.++* Allowed `QuickCheck-2.10`.++## Megaparsec 5.3.0++* Added the `match` combinator that allows to get collection of consumed+  tokens along with result of parsing.++* Added the `region` combinator which allows to process parse errors+  happening when its argument parser is run.++* Added the `getNextTokenPosition`, which returns position where the next+  token in the stream begins.++* Defined `Semigroup` and `Monoid` instances of `ParsecT`.++* Dropped support for GHC 7.6.++* Added an `ErrorComponent` instance for `()`.++## Megaparsec 5.2.0++* Added `MonadParsec` instance for `RWST`.++* Allowed `many` to run parsers that do not consume input. Previously this+  signalled an `error` which was ugly. Of course, in most cases giving+  `many` a parser that do not consume input will lead to non-termination+  bugs, but there are legal cases when this should be allowed. The test+  suite now contains an example of this. Non-termination issues is something+  inherited from the power Megaparsec gives (with more power comes more+  responsibility), so that `error` case in `many` really does not solve the+  problem, it was just a little ah-hoc guard we got from Parsec's past.++* The criterion benchmark was completely re-written and a new weigh+  benchmark to analyze memory consumption was added.++* Performance improvements: `count` (marginal improvement, simpler+  implementation), `count'` (considerable improvement), and `many`+  (marginal improvement, simpler implementation).++* Added `stateTokensProcessed` field to parser state and helper functions+  `getTokensProcessed` and `setTokensProcessed`. The field contains number+  of processed tokens so far. This allows, for example, create wrappers that+  return just parsed fragment of input stream alongside with result of+  parsing. (It was possible before, but very inefficient because it required+  traversing entire input stream twice.)++* `IndentNone` option of `indentBlock` now picks whitespace after it like+  its sisters `IndentMany` and `IndentSome` do, see #161.++* Fixed a couple of quite subtle bugs in `indentBlock` introduced by+  changing behaviour of `skipLineComment` in version 5.1.0. See #178 for+  more information.++## Megaparsec 5.1.2++* Stopped using property tests with `dbg` helper to avoid flood of debugging+  info when test suite is run.++* Fixed the build with `QuickCheck` versions older than 2.9.0.++## Megaparsec 5.1.1++* Exported the `observing` primitive from `Text.Megaparsec`.++## Megaparsec 5.1.0++* Defined `displayException` for `ParseError`, so exceptions are displayed+  in human-friendly form now. This works with GHC 7.10 and later.++* Line comments parsed by `skipLineComment` now may end at the end of input+  and do not necessarily require a newline to be parsed correctly. See #119.++* Exposed `parseErrorTextPretty` function in `Text.Megaparsec.Error` to+  allow to render `ParseError`s without stack of source positions.++* Eliminated the `old-tests` test suite — Parsec legacy. The cases that are+  not already *obviously* covered in the main test suite were included into+  it.++* Added `Arbitrary` instances for the following data types: `Pos`,+  `SourcePos`, `ErrorItem`, `Dec`, `ParseError` and `State`. This should+  make testing easier without the need to add orphan instances every time.+  The drawback is that we start to depend on `QuickCheck`, but that's a fair+  price.++* The test suite now uses the combination of Hspec and the+  `hpesc-megaparsec` package, which also improved the latter (that package+  is the recommended way to test Megaparsec parsers).++* The `try` combinator now truly backtracks parser state when its argument+  parser fails (either consuming input or not). Most users will never notice+  the difference though. See #142.++* Added the `dbg` function that should be helpful for debugging.++* Added `observing` primitive combinator that allows to “observe” parse+  errors without ending parsing (they are returned in `Left`, while normal+  results are wrapped in `Right`).++* Further documentation improvements.+ ## Megaparsec 5.0.1  * Derived `NFData` instances for `Pos`, `InvalidPosException`, `SourcePos`,@@ -292,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–2016 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,339 +4,349 @@ [![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) * [Performance](#performance) * [Comparison with other solutions](#comparison-with-other-solutions)-    * [Megaparsec and Attoparsec](#megaparsec-and-attoparsec)-    * [Megaparsec and Parsec](#megaparsec-and-parsec)-    * [Megaparsec and Parsers](#megaparsec-and-parsers)+    * [Megaparsec vs Attoparsec](#megaparsec-vs-attoparsec)+    * [Megaparsec vs Parsec](#megaparsec-vs-parsec)+    * [Megaparsec vs Trifecta](#megaparsec-vs-trifecta)+    * [Megaparsec vs Earley](#megaparsec-vs-earley) * [Related packages](#related-packages)-* [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 documentation, see the-[section about documentation](#documentation).+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`, a MTL-style monad-transformer. All tools and features work with any instance of-`MonadParsec`. You can achieve various effects combining monad transformers,-i.e. building monad stack. Since most common monad transformers like-`WriterT`, `StateT`, `ReaderT` and others are instances of `MonadParsec`,-you can wrap `ParsecT` *in* these monads, achieving, for example,-backtracking state.+The package is built around `MonadParsec`, an MTL-style monad transformer.+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 instance of many type classes as well. The+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 any instance of `Alternative` and some-even with instances of `Applicative`.--Role of `Monad`, `Applicative`, and `Alternative` should be obvious, so-let's enumerate methods of `MonadParsec` type class. The class represents-core, basic functions of Megaparsec parsing. The rest of library is built-via combination of these primitives:--* `failure` allows to fail with arbitrary collection of messages.--* `label` allows to add a “label” to any parser, so when it fails the user will-  see the label in the error message where “expected” items are enumerated.--* `hidden` hides any parser from error messages altogether, this is-  officially recommended way to hide things, prefer it to the `label ""`-  approach.--* `try` enables backtracking in parsing.--* `lookAhead` allows to parse something without consuming input.--* `notFollowedBy` succeeds when its argument fails, it 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.--* `eof` only succeeds at the end of input.--* `token` is used to parse single token.--* `tokens` makes it easy to parse several tokens in a row.--* `getParserState` returns full parser state.+* `observing` makes it possible to “observe” parse errors without ending+  parsing. -* `updateParserState` applies given function on parser state.+In addition to that, Megaparsec features high-performance combinators+similar to those found in [Attoparsec][attoparsec]: -This list of core functions is longer than in some other libraries. Our goal-was efficient and readable implementation of functionality provided by every-such primitive, not minimal number of them. You can read the comprehensive-description of every primitive function in-[Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html).+* `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. -Megaparsec can currently work with the following types of input stream:+Megaparsec is about as fast as Attoparsec if you write your parser carefully+(see also [the section about performance](#performance)). -* `String` = `[Char]`+The library can currently work with the following types of input stream+out-of-the-box: +* `String = [Char]` * `ByteString` (strict and lazy)- * `Text` (strict and lazy) +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 ability to use custom-data types to adjust the library to your domain of interest. No need to keep-your info as 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 `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 with little effort.+* 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 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 — all cases are covered.+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 [`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) (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 given characters, or any character except for given ones, or-  character satisfying given predicate. Case-insensitive versions of the-  parsers are available.--* *Parsers for sequences of characters* parse strings. These are more-  efficient and provide better error messages than other approaches most-  programmers can come up with. 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 qualified, 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 visit [site of the project](https://mrkkrp.github.io/megaparsec/)-which has [several tutorials](https://mrkkrp.github.io/megaparsec/tutorials.html) that-should help you to start with your parsing tasks. The site also has-instructions and tips for Parsec users who decide to switch.+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): +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, let's compare Megaparsec with some of them. -### Megaparsec and Attoparsec+### 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 and Parsec+### Megaparsec vs Parsec -Since Megaparsec is a fork of Parsec, it's necessary to list 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-  compiler or 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.+* Better documentation. -* We have benchmarks to detect performance regressions.+* Megaparsec can recover from parse errors “on the fly” and continue+  parsing. -* 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 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's code is clearer and doesn't contain “magic” found in original-  Parsec.+* Megaparsec is faster and supports efficient operations `tokens`,+  `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec. -* Megaparsec has well-typed error messages and custom error messages.+If you want to see a detailed change log, `CHANGELOG.md` may be helpful.+Also see [this original announcement][original-announcement] for another+comparison. -* Megaparsec can recover from parse errors “on the fly” and continue-  parsing.+### Megaparsec vs Trifecta -* Megaparsec is faster.+[Trifecta][trifecta] is another Haskell library featuring good error+messages. These are the common reasons why Trifecta may be problematic to+use: -If you want to see a detailed change log, `CHANGELOG.md` may be helpful.+* Complicated, doesn't have any tutorials available, and documentation+  doesn't help much. -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 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 original Parsec-project. If you think you still have a reason to use original Parsec, open-an issue.+* Trifecta can parse `String` and `ByteString` natively, but not `Text`. -### Megaparsec and Parsers+* Depends on `lens`, which is a very heavy dependency. If you're not into+  `lens`, you may not like the API. -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:+[Idris][idris] has switched from Trifecta to Megaparsec which allowed it to+[have better error messages and fewer dependencies][idris-testimony]. -* It depends on *both* Attoparsec and Parsec, which means you always grab-  useless code installing 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”. But with these-  useful functions you get two more parsers as dependencies.+### Megaparsec vs Earley -* It currently has a bug 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.+[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: -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 lexer. So it didn't happen, Megaparsec has minimal dependencies,-it is feature-rich and self-contained.+* 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+  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.++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-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities+  for testing Megaparsec parsers with with   [Hspec](https://hackage.haskell.org/package/hspec).+* [`replace-megaparsec`](https://hackage.haskell.org/package/replace-megaparsec)—Stream+  editing and find-and-replace with Megaparsec.+* [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec)—Megaparsec+  parser of CSV files that plays nicely with+  [Cassava](https://hackage.haskell.org/package/cassava).+* [`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.+* [`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. -## Authors+## Prominent projects that use Megaparsec -The project was started and is currently maintained by Mark Karpov. You can-find complete list of contributors in `AUTHORS.md` file in 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.+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][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).--Pull requests are also welcome (and yes, they will get attention and will be-merged quickly if they are good, we are progressive folks).+[the GitHub issue tracker for this+project](https://github.com/mrkkrp/megaparsec/issues). -If you want to write a tutorial to be hosted on Megaparsec's site, open an-issue or pull request [here](https://github.com/mrkkrp/megaparsec-site).+Pull requests are also welcome. If you would like to contribute to the+project, you may find [this document][hacking] helpful.  ## License -Copyright © 2015–2016 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,196 +1,664 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Module      :  Text.Megaparsec--- Copyright   :  © 2015–2016 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD ----- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com> -- Stability   :  experimental -- Portability :  portable -- -- 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 our tutorials <https://mrkkrp.github.io/megaparsec/tutorials.html>.+-- at the tutorial <https://markkarpov.com/tutorial/megaparsec.html>. ----- 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:+-- 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. ----- > import Text.Megaparsec.Prim--- > import Text.Megaparsec.Combinator+-- It is common to start working with the library by defining a type synonym+-- like this: ----- Then you can implement your own version of 'satisfy' on top of the--- 'token' primitive.+-- > type Parser = Parsec Void Text+-- >                      ^    ^+-- >                      |    |+-- > Custom error component    Input stream type ----- Typical import section looks like this:+-- Then you can write type signatures like @Parser 'Int'@—for a parser that+-- returns an 'Int' for example. ----- > 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+-- Similarly (since it's known to cause confusion), you should use+-- 'ParseErrorBundle' type parametrized like this: ----- As you can see the second import depends on data type you want to use as--- input stream. It just defines useful type-synonym @Parser@.+-- > 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-  , runParser-  , runParser'-  , runParserT-  , runParserT'-  , parse-  , parseMaybe-  , parseTest-    -- * Combinators-  , (A.<|>)-  -- $assocbo-  , A.many-  -- $many-  , A.some-  -- $some-  , A.optional-  -- $optional-  , unexpected-  , failure-  , (<?>)-  , label-  , hidden-  , try-  , lookAhead-  , notFollowedBy-  , withRecovery-  , 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-    -- * Low-level operations-  , Stream (..)-  , State (..)-  , getInput-  , setInput-  , getPosition-  , setPosition-  , pushPosition-  , popPosition-  , 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. Returns a list of--- the returned values of @p@.+-- > 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 (alphaNum <|> 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. Returns a list of--- the returned values of @p@.+-- 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 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,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString--- Copyright   :  © 2015–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 user can use it to easily change type of input stream by--- importing different “type modules”. This one is for strict byte-strings.--type Parser = Parsec Dec ByteString
− Text/Megaparsec/ByteString/Lazy.hs 
@@ -1,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString.Lazy--- Copyright   :  © 2015–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 user can use it to easily change type of input stream by--- importing different “type modules”. This one is for lazy byte-strings.--type Parser = Parsec Dec ByteString
Text/Megaparsec/Char.hs view
@@ -1,301 +1,299 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | -- Module      :  Text.Megaparsec.Char--- Copyright   :  © 2015–2016 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors --                © 2007 Paolo Martini --                © 1999–2001 Daan Leijen -- License     :  FreeBSD ----- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com> -- Stability   :  experimental -- 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 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 Control.Applicative ((<$>), pure)-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 --- | Parses a newline character.--newline :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a newline character.+newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-} --- | Parses a carriage return character followed by a newline character.--- Returns sequence of characters parsed.--crlf :: (MonadParsec e s m, Token s ~ Char) => m String-crlf = string "\r\n"+-- | Parse a carriage return character followed by a newline character.+-- Return the sequence of characters parsed.+crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s)+crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-} --- | Parses a CRLF (see 'crlf') or LF (see 'newline') end of line. Returns--- the sequence of characters parsed.------ > eol = (pure <$> newline) <|> crlf--eol :: (MonadParsec e s m, Token s ~ Char) => m String-eol = (pure <$> newline) <|> crlf <?> "end of line"+-- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the+-- sequence of characters parsed.+eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s)+eol =+  (tokenToChunk (Proxy :: Proxy s) <$> newline)+    <|> crlf+    <?> "end of line" {-# INLINE eol #-} --- | Parses a tab character.--tab :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a tab character.+tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-} --- | Skips /zero/ or more white space characters.+-- | 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 --- | Parses control characters, which are the non-printing characters of the--- Latin-1 subset of Unicode.--controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a control character (a non-printing character of the Latin-1+-- subset of Unicode).+controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl <?> "control character" {-# INLINE controlChar #-} --- | Parses a Unicode space character, and the control characters: tab,+-- | 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 #-} --- | Parses an upper-case or title-case alphabetic Unicode character. Title+-- | 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 #-} --- | Parses a lower-case alphabetic Unicode character.--lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a lower-case alphabetic Unicode character.+lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower <?> "lowercase letter" {-# INLINE lowerChar #-} --- | Parses alphabetic Unicode characters: lower-case, upper-case and--- title-case letters, plus letters of case-less scripts and modifiers--- letters.--letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse an alphabetic Unicode character: lower-case, upper-case, or+-- title-case letter, or a letter of case-less scripts\/modifier letter.+letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter <?> "letter" {-# INLINE letterChar #-} --- | Parses alphabetic or numeric digit Unicode characters.+-- | Parse an alphabetic or numeric digit Unicode characters. ----- Note that numeric digits outside the ASCII range are parsed by this+-- 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 #-} --- | Parses printable Unicode characters: letters, numbers, marks,--- punctuation, symbols and spaces.--printChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a printable Unicode character: letter, number, mark, punctuation,+-- symbol or space.+printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint <?> "printable character" {-# INLINE printChar #-} --- | Parses an ASCII digit, i.e between “0” and “9”.--digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse an ASCII digit, i.e between “0” and “9”.+digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit <?> "digit" {-# INLINE digitChar #-} --- | Parses 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 #-} --- | Parses 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+-- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or+-- “A” and “F”.+hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit <?> "hexadecimal digit" {-# INLINE hexDigitChar #-} --- | Parses Unicode mark characters, for example accents and the like, which--- combine with preceding characters.--markChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a Unicode mark character (accents and the like), which combines+-- with preceding characters.+markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark <?> "mark character" {-# INLINE markChar #-} --- | Parses Unicode numeric characters, including digits from various--- scripts, Roman numerals, et cetera.--numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a Unicode numeric character, including digits from various+-- scripts, Roman numerals, etc.+numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber <?> "numeric character" {-# INLINE numberChar #-} --- | Parses Unicode punctuation characters, including various kinds of+-- | 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 #-} --- | Parses Unicode symbol characters, including mathematical and currency+-- | 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 #-} --- | Parses Unicode space and separator characters.--separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char+-- | Parse a Unicode space and separator characters.+separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator <?> "separator" {-# INLINE separatorChar #-} --- | Parses 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+-- | Parse a character from the first 128 characters of the Unicode+-- character set, corresponding to the ASCII character set.+asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii <?> "ASCII character" {-# INLINE asciiChar #-} --- | Parses a character from the first 256 characters of the Unicode+-- | 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 #-} --- | Returns human-readable name of Unicode General Category.-+-- | 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 actually--- parsed character preserving its case.+-- | The same as 'char' but case-insensitive. This parser returns the+-- actually parsed character preserving its case. -- -- >>> parseTest (char' 'e') "E" -- 'E'@@ -303,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--- list of characters @cs@. Returns the parsed character. Note that this--- parser doesn't automatically generate “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 = toLower x == toLower 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,182 +0,0 @@--- |--- Module      :  Text.Megaparsec.Combinator--- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- Stability   :  experimental--- Portability :  portable------ Commonly used generic combinators. Note that all combinators works with--- any 'Alternative' instances.--{-# 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-  | n <= 0    = pure []-  | otherwise = 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-  | n <= 0 || m > n = pure []-  | m > 0           = (:) <$> p <*> count' (pred m) (pred n) p-  | otherwise       =-      let f t ts = maybe [] (:ts) t-      in f <$> optional p <*> count' 0 (pred n) p---- | 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 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,273 +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–2016 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD ----- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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 )+  ( -- * 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 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--- parse error. The data type is parametrized over 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)---- | 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 message passed to 'fail' in parser monad.-  ---  -- @since 5.0.0--  representFail :: String -> e--  -- | Represent information about incorrect indentation.-  ---  -- @since 5.0.0+  = -- | 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) -  representIndentation-    :: Ordering -- ^ Desired ordering between reference level and actual level-    -> Pos             -- ^ Reference indentation level-    -> Pos             -- ^ Actual indentation level-    -> e+instance (NFData t) => NFData (ErrorItem t) --- | “Default error component”. This in 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+    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 --- | The data type @ParseError@ represents parse errors. It provides the--- stack of source positions, set of expected and unexpected tokens as well--- as set of custom associated data. The data type is parametrized over--- token type @t@ and custom data @e@.+-- | @'ParseError' s e@ represents a parse error parametrized over the+-- stream type @s@ and the custom data @e@. ----- Note that 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.+-- 'Semigroup' and 'Monoid' instances of the data type allow us to merge+-- parse errors from different branches of parsing. When merging two+-- 'ParseError's, the longest match is preferred; if positions are the same,+-- custom data sets and collections of message items are combined. Note that+-- fancy errors take precedence over trivial errors in merging. ----- 'Semigroup' (or 'Monoid') instance of the data type allows to merge parse--- errors from different branches of parsing. When merging two--- 'ParseError's, longest match is preferred; if positions are the same,--- custom data sets and collections of message items are combined.+-- @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, Show e, Typeable e) => Exception (ParseError t e)+instance+  ( Show (Token s),+    Show e,+    ShowErrorComponent e,+    VisualStream s,+    Typeable s,+    Typeable e+  ) =>+  Exception (ParseError s e)+  where+  displayException = parseErrorPretty --- | Merge two error data structures into one joining their collections of--- message items and preferring 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.+-- | 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) -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+-- | 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 ::+  (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 '\0' = "null"-charPretty '\a' = "bell"-charPretty '\b' = "backspace"-charPretty '\t' = "tab"-charPretty '\n' = "newline"-charPretty '\v' = "vertical tab"-charPretty '\f' = "form feed"-charPretty '\r' = "carriage return"-charPretty ' '  = "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) --- | Pretty-print 'ParseError'. Note that rendered 'String' always ends with--- a newline.+    indent :: String -> String+    indent =+      lines >>> \case+        [err] -> err+        err -> intercalate "\n" $ map (" " <>) err++-- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a+-- newline. -- -- @since 5.0.0+parseErrorPretty ::+  (VisualStream s, ShowErrorComponent e) =>+  -- | Parse error to render+  ParseError s e ->+  -- | Result of rendering+  String+parseErrorPretty e =+  "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e -parseErrorPretty :: ( Ord t-                    , ShowToken t-                    , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorPretty (ParseError pos us ps xs) =-  sourcePosStackPretty pos ++ ":\n" ++-  if E.null us && E.null ps && E.null xs+-- | 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.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 concat-      [ messageItemsPretty "unexpected " us-      , messageItemsPretty "expecting "  ps-      , unlines (showErrorComponent <$> E.toAscList xs) ]+    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) --- | Pretty-print stack of source positions.+----------------------------------------------------------------------------+-- Helpers++-- | Pretty-print an 'ErrorItem'. ----- @since 5.0.0+-- @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" -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"+-- | 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 --- | Transforms list of error messages into their textual representation.+-- | 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 -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 '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 rules of English punctuation.-+-- “or” according to the rules of English punctuation. orList :: NonEmpty String -> String-orList (x:|[])  = x-orList (x:|[y]) = x ++ " or " ++ y-orList xs       = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs+orList (x :| []) = x+orList (x :| [y]) = x <> " or " <> y+orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
+ Text/Megaparsec/Error.hs-boot view
@@ -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,152 +0,0 @@--- |--- Module      :  Text.Megaparsec.Expr--- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 @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 you don't want to allow--- repeating prefix or postfix operators.------ @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 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 term with @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,122 +1,91 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+ -- |--- Module      :  Text.Megaparsec.Lexer--- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018–present Megaparsec contributors -- License     :  FreeBSD ----- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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 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 ((<|>), some, optional)-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--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (*>), (<*>), pure)-#endif+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. '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 wrapper for lexemes. Typical usage is to supply first argument--- (parser that consumes white space, probably defined via 'space') and use--- the resulting function to wrap parsers for every lexeme.+-- | 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@@ -132,358 +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 parser that skips line--- comments. Note that it stops just before 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 C.newline---- | @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 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 column--- position. Ordering between current indentation level and reference--- indentation level @ref@ should be @ord@, otherwise the parser fails. On--- success current column position is returned.------ When you want to parse 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 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 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 -> return x-    IndentMany indent f p -> do-      mlvl <- optional . try $ C.eol *> indentGuard sc GT ref-      case mlvl of-        Nothing  -> sc *> f []-        Just lvl -> indentedItems ref (fromMaybe lvl indent) sc p >>= f-    IndentSome indent f p -> do-      lvl <- C.eol *> indentGuard sc GT ref-      indentedItems ref (fromMaybe lvl indent) sc p >>= f---- | Grab indented items. This is a helper for 'indentBlock', it's not a--- part of 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 = (sc *> indentLevel) >>= re-    re pos-      | pos <= ref = return []-      | pos == lvl = (:) <$> p <*> go-      | otherwise  = do-          done <- isJust <$> optional eof-          if done-            then return []-            else 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 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. 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 '"')--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--- format of integer literals described in 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 Haskell report except--- for the fact that this parser doesn't parse “0x” or “0X” prefix. It is--- 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 Haskell report except for the fact--- that this parser doesn't parse “0o” or “0O” prefix. It is 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 floating point value as '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 floating point value is expected to be according to--- 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 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 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–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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,96 +1,90 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}+ -- | -- Module      :  Text.Megaparsec.Pos--- Copyright   :  © 2015–2016 Megaparsec contributors+-- Copyright   :  © 2015–present Megaparsec contributors -- License     :  FreeBSD ----- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com> -- Stability   :  experimental -- 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 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 Unsafe.Coerce -#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)+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 = unsafeCoerce-{-# INLINE unPos #-}+defaultTabWidth :: Pos+defaultTabWidth = mkPos 8  instance Semigroup Pos where   (Pos x) <> (Pos y) = Pos (x + y)@@ -100,84 +94,52 @@   readsPrec d =     readParen (d > 10) $ \r1 -> do       ("Pos", r2) <- lex r1-      (x,     r3) <- readsPrec 11 r2-      (,r3) <$> mkPos (x :: Integer)+      (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 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 default tab width because actual value /may/ change--- in future. Current value is @8@.--defaultTabWidth :: Pos-defaultTabWidth = unsafePos 8+    showLC = show (unPos l) <> ":" <> show (unPos c)
− Text/Megaparsec/Prim.hs 
@@ -1,1141 +0,0 @@--- |--- Module      :  Text.Megaparsec.Prim--- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 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-    -- * Parser state combinators-  , getInput-  , setInput-  , getPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTabWidth-  , setTabWidth-  , setParserState-    -- * Running parser-  , runParser-  , runParser'-  , runParserT-  , runParserT'-  , parse-  , parseMaybe-  , parseTest )-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.NonEmpty (NonEmpty (..))-import Data.Monoid hiding ((<>))-import Data.Proxy-import Data.Semigroup-import Data.Set (Set)-import Data.Typeable (Typeable)-import GHC.Generics-import Prelude hiding (all)-import qualified Control.Applicative               as A-import qualified Control.Monad.Fail                as Fail-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 ((<$>), (<*), pure)-#endif--------------------------------------------------------------------------------- Data types---- | This is Megaparsec's state, it's parametrized over stream type @s@.--data State s = State-  { stateInput    :: s-  , statePos      :: NonEmpty SourcePos-  , stateTabWidth :: Pos }-  deriving (Show, Eq, Data, Typeable, Generic)--instance NFData s => NFData (State s)---- | 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 most recent group of hints (if any) with 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 parser's state.-  ---  -- When you work with streams where elements do not contain information-  -- about their position in input, 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 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 actual element position and provide the end position of the-  -- token as 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 #-}---- If you're reading this, you may be interested in how Megaparsec works on--- lower level. That's quite simple. 'ParsecT' is a wrapper around function--- that takes five arguments:------     * State. It includes input stream, position in input stream and---     current value of tab width.------     * “Consumed-OK” continuation (cok). This is a function that takes---     three arguments: result of parsing, state after parsing, and hints---     (see their description above). This continuation is called when---     something has been consumed during parsing and result is OK (no error---     occurred).------     * “Consumed-error” continuation (cerr). This function is called when---     some part of input stream has been consumed and parsing resulted in---     an error. This continuation takes 'ParseError' and state information---     at the time error occurred.------     * “Empty-OK” continuation (eok). The function takes the same---     arguments as “consumed-OK” continuation. “Empty-OK” is called when no---     input has been consumed and no error occurred.------     * “Empty-error” continuation (eerr). The function is called when no---     input has been consumed, but nonetheless parsing resulted in an---     error. Just like “consumed-error”, the continuation takes---     'ParseError' record and state information.------ You call specific continuation when you want to proceed in that specific--- branch of control flow.---- | @Parsec@ is non-transformer variant of 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 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-  many p = reverse <$> manyAcc p--manyAcc :: ParsecT e s m a -> ParsecT e s m [a]-manyAcc p = ParsecT $ \s cok cerr eok _ ->-  let errToHints c err _ = c (toHints err)-      walk xs x s' _ =-        unParser p s'-        (seq xs $ walk $ x:xs)       -- consumed-OK-        cerr                         -- consumed-error-        manyErr                      -- empty-OK-        (errToHints $ cok (x:xs) s') -- empty-error-  in unParser p s (walk []) cerr manyErr (errToHints $ eok [] s)--manyErr :: a-manyErr = error $-  "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser"-  ++ " that may consume no input."--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 #-}---- | Low-level creation of the 'ParsecT' type.--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 greater textual position. If the--- positions are equal, prefer the latter state.--longestMatch :: State s -> State s -> State s-longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) =-  case pos1 `compare` pos2 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 '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-  -- pretends that it hasn't consumed any input when an error occurs.-  ---  -- 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 word “let” or-  -- “lexical”:-  ---  -- >>> parseTest (string "let" <|> string "lexical") "lexical"-  -- 1:1:-  -- unexpected "lex"-  -- expecting "let"-  ---  -- What happens here? 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.--  try :: m a -> m a--  -- | @lookAhead p@ parses @p@ without consuming any input.-  ---  -- If @p@ fails and consumes some input, so does @lookAhead@. Combine with-  -- 'try' if this is undesirable.--  lookAhead :: m a -> m a--  -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser-  -- does not consume any input and 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 actual 'ParseError' as its argument.-  -- Typical usage is to return value signifying failure to parse this-  -- particular object and to consume some part of input up to start of next-  -- object.-  ---  -- 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--  -- | 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 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]--  -- | Returns the full parser state as a 'State' record.--  getParserState :: m (State s)--  -- | @updateParserState f@ applies 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-  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 "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 ->-  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 #-}--pEof :: forall e s m. Stream s => ParsecT e s m ()-pEof = ParsecT $ \s@(State input (pos:|z) 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) 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) 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) w)-        Right x ->-          let newstate = State cs (npos:|z) 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) 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 = foldl' (\p t -> snd (updatePos' p t)) pos ris-        in cok ris (State rs (npos:|z) 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) 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) 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) 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 form of an operator.--infix 0 <?>--(<?>) :: MonadParsec e s m => m a -> String -> m a-(<?>) = flip label---- | The parser @unexpected item@ always 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 #-}---- | 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 w) -> State s pos 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---- | @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) w) ->-  State s (pos:|z) w---- | Push given 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 w) ->-  State s (NE.cons pos z) w---- | Pop a position from stack of positions unless it only contains one--- element (in that case 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 w) ->-  case snd (NE.uncons z) of-    Nothing -> State s z w-    Just z' -> State s z' w---- | Return tab width. Default tab width is equal to 'defaultTabWidth'. You--- can set different tab width with help of 'setTabWidth'.--getTabWidth :: MonadParsec e s m => m Pos-getTabWidth = stateTabWidth <$> getParserState---- | Set tab width. If argument of the function is not positive number,--- 'defaultTabWidth' will be used.--setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState (\(State s pos _) -> State s pos w)---- | @setParserState st@ set the full 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 parser @p@ on @input@ and returns 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 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 a 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 list 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)---- | Given name of source file and input construct initial state for parser.--initialState :: String -> s -> State s-initialState name s = State s (initialPos name :| []) defaultTabWidth---- | 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)--------------------------------------------------------------------------------- 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)-  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)-  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 st 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)-  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-  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-  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-  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
+ 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–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 user can use it to easily change type of input stream by--- importing different “type modules”. This one is for strings.--type Parser = Parsec Dec String
− Text/Megaparsec/Text.hs 
@@ -1,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text--- Copyright   :  © 2015–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 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,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text.Lazy--- Copyright   :  © 2015–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- 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 user can use it to easily change type of 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 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))
− benchmarks/Main.hs 
@@ -1,192 +0,0 @@------ Criterion benchmarks for Megaparsec.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP #-}--module Main (main) where--import Criterion.Main--import Text.Megaparsec---- Configuration parameters.---- To configure the benchmark, build the benchmarks e.g. like this:--- $ cabal build --ghc-options="-DBENCHMARK_TYPE=3 -DBENCHMARK_STEPS=10"---- BENCHMARK_TYPE options:--- 0:  Text.Megaparsec.String--- 1:  Text.Megaparsec.Text--- 2:  Text.Megaparsec.Text.Lazy--- 3:  Text.Megaparsec.ByteString--- 4:  Text.Megaparsec.ByteString.Lazy--#ifndef BENCHMARK_TYPE-#define BENCHMARK_TYPE 0-#endif--#if BENCHMARK_TYPE == 0-import Text.Megaparsec.String (Parser)-pack :: String -> String-pack = id-#endif-#if BENCHMARK_TYPE == 1-import Text.Megaparsec.Text (Parser)-import Data.Text (pack)-#endif-#if BENCHMARK_TYPE == 2-import Text.Megaparsec.Text.Lazy (Parser)-import Data.Text.Lazy (pack)-#endif-#if BENCHMARK_TYPE == 3-import Text.Megaparsec.ByteString (Parser)-import Data.ByteString.Char8 (pack)-#endif-#if BENCHMARK_TYPE == 4-import Text.Megaparsec.ByteString.Lazy (Parser)-import Data.ByteString.Lazy.Char8 (pack)-#endif---- benchSteps and benchSize control the benchmark test points--benchSteps :: Int-#if BENCHMARK_STEPS-benchSteps = BENCHMARK_STEPS-#else-benchSteps = 5-#endif-benchSize :: Int-#if BENCHMARK_SIZE-benchSize = BENCHMARK_SIZE-#else-benchSize = 1000-#endif---- End of configuration parameters--main :: IO ()-main = defaultMain benchmarks--benchmarks :: [Benchmark]-benchmarks =-  [-  -- First the primitives-    bgroup "string" $ benchBunch $ \size str ->-      parse (string str :: Parser String) ""-        (pack $ replicate size 'a')-  , bgroup "try-string" $ benchBunch $ \size str ->-      parse (try $ string str :: Parser String) ""-        (pack $ replicate size 'a')-  , bgroup "lookahead-string" $ benchBunch $ \size str ->-      parse (lookAhead $ string str :: Parser String) ""-        (pack $ replicate size 'a')-  , bgroup "notfollowedby-string" $ benchBunch $ \size str ->-      parse (notFollowedBy $ string str :: Parser ()) ""-        (pack $ replicate size 'a')-  , bgroup "manual-string" benchManual--  -- Now for a few combinators-  -- Major class instance operators: return, >>=, <|>, mzero-  -- TODO-  -- I'm not really sure how to test these operators since I can't imagine what-  -- supraconstant complexity they might have.--  -- A few non-primitive combinators follow below-  , bgroup "choice"-      [ bgroup "match" $ benchBunchMatch $ \size _ ->-          parse-            (choice (replicate (size-1) (char 'b') ++ [char 'a']) :: Parser Char)-            ""-            (pack $ replicate size 'a')-      , bgroup "nomatch" $ benchBunchMatch $ \size _ ->-          parse-            (choice (replicate size (char 'b')) :: Parser Char)-            ""-            (pack $ replicate size 'a')-      ]-  , bgroup "count'" benchCount-  , bgroup "sepBy1" benchSepBy1-  , bgroup "manyTill" $ benchBunchNoMatchLate $ \size _ ->-      parse-        (manyTill (char 'a') (char 'b') :: Parser String)-        ""-        (pack $ replicate (size-1) 'a' ++ "b")-  ]--benchManual :: [Benchmark]-benchManual =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf-      (parse (sequence $ fmap char (replicate num 'a') :: Parser String) "")-      (pack $ replicate num 'a')--benchCount :: [Benchmark]-benchCount =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf-      (parse (count' size (size*2) (char 'a') :: Parser String) "")-      (pack $ replicate (num-1) 'a' ++ "b")-      where-        size = round ((0.7 :: Double) * fromIntegral num)--benchSepBy1 :: [Benchmark]-benchSepBy1 =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf-      (parse (sepBy1 (char 'a') (char 'b') :: Parser String) "")-      (pack $ genString num)-    genString 0 = "ac"-    genString i = 'a' : 'b' : genString (i-1)--benchBunch :: (Int -> String -> b) -> [Benchmark]-benchBunch f =-  [ bgroup "match" $ benchBunchMatch f-  , bgroup "nomatch_early" $ benchBunchNoMatchEarly f-  , bgroup "nomatch_late" $ benchBunchNoMatchLate f-  ]--benchBunchMatch :: (Int -> String -> b) -> [Benchmark]-benchBunchMatch f =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf (f num) (replicate num 'a')--benchBunchNoMatchEarly :: (Int -> String -> b) -> [Benchmark]-benchBunchNoMatchEarly f =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf (f num) (replicate num 'b')--benchBunchNoMatchLate :: (Int -> String -> b) -> [Benchmark]-benchBunchNoMatchLate f =-  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]-  where-    benchOne num = bench (show num) $ whnf (f num) (replicate (num-1) 'a' ++ "b")
megaparsec.cabal view
@@ -1,181 +1,127 @@------ Cabal config for Megaparsec.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.+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> -name:                 megaparsec-version:              5.0.1-cabal-version:        >= 1.10-license:              BSD2-license-file:         LICENSE.md-author:               Megaparsec contributors,-                      Paolo Martini <paolo@nemail.it>,-                      Daan Leijen <daan@microsoft.com>+tested-with:+    ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1 -maintainer:           Mark Karpov <markkarpov@opmbx.org>-homepage:             https://github.com/mrkkrp/megaparsec-bug-reports:          https://github.com/mrkkrp/megaparsec/issues-category:             Parsing-synopsis:             Monadic parser combinators-build-type:           Simple+homepage:        https://github.com/mrkkrp/megaparsec+bug-reports:     https://github.com/mrkkrp/megaparsec/issues+synopsis:        Monadic parser combinators description:+    This is an industrial-strength monadic parser combinator library.+    Megaparsec is a feature-rich package that tries to find a nice balance+    between speed, flexibility, and quality of parse errors. -  This is industrial-strength monadic parser combinator library. Megaparsec-  is a fork of Parsec library originally written by Daan Leijen.+category:        Parsing+build-type:      Simple+extra-doc-files:+    CHANGELOG.md+    README.md -extra-source-files:   AUTHORS.md-                    , CHANGELOG.md-                    , README.md+source-repository head+    type:     git+    location: https://github.com/mrkkrp/megaparsec.git  flag dev-  description:        Turn on development settings.-  manual:             True-  default:            False+    description: Turn on development settings.+    default:     False+    manual:      True  library-  build-depends:      base         >= 4.6   && < 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-    if impl(ghc >= 8.0)-      ghc-options:    -Wcompat-      ghc-options:    -Wnoncanonical-monadfail-instances-      ghc-options:    -Wnoncanonical-monoid-instances-  else-    ghc-options:      -O2 -Wall-  default-language:   Haskell2010+    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -test-suite old-tests-  main-is:            Main.hs-  hs-source-dirs:     old-tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  other-modules:      Bugs-                    , Bugs.Bug2-                    , Bugs.Bug6-                    , Bugs.Bug9-                    , Bugs.Bug35-                    , Bugs.Bug39-                    , Util-  build-depends:      base                 >= 4.6 && < 5.0-                    , HUnit                >= 1.2 && < 1.4-                    , megaparsec           >= 5.0.1-                    , test-framework       >= 0.6 && < 1.0-                    , test-framework-hunit >= 0.2 && < 0.4-  default-language:   Haskell2010+    else+        ghc-options: -O2 -Wall -test-suite tests-  main-is:            Main.hs-  hs-source-dirs:     tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  other-modules:      Char-                    , Combinator-                    , Error-                    , Expr-                    , Lexer-                    , Perm-                    , Pos-                    , Prim-                    , Util-  build-depends:      base           >= 4.6   && < 5.0-                    , HUnit          >= 1.2   && < 1.4-                    , QuickCheck     >= 2.8.2 && < 3.0-                    , bytestring     >= 0.2   && < 0.11-                    , containers     >= 0.5   && < 0.6-                    , exceptions     >= 0.6   && < 0.9-                    , megaparsec     >= 5.0.1-                    , mtl            >= 2.0   && < 3.0-                    , scientific     >= 0.3.1 && < 0.4-                    , test-framework >= 0.6   && < 1.0-                    , test-framework-hunit       >= 0.3 && < 0.4-                    , test-framework-quickcheck2 >= 0.3 && < 0.4-                    , text           >= 0.2   && < 1.3-                    , transformers   >= 0.4   && < 0.6+    if impl(ghc >=9.8)+        ghc-options: -Wno-x-partial -  if !impl(ghc >= 8.0)-    -- packages providing modules that moved into base-4.9.0.0-    build-depends:    semigroups     == 0.18.*+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 -  if !impl(ghc >= 7.8)-    build-depends:    tagged       == 0.8.*+    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -  default-language:   Haskell2010+    else+        ghc-options: -O2 -Wall -benchmark benchmarks-  main-is:            Main.hs-  hs-source-dirs:     benchmarks-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -O2 -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  build-depends:      base       >= 4.6  && < 5.0-                    , bytestring >= 0.10 && < 0.11-                    , criterion  >= 0.6.2.1 && < 1.2-                    , megaparsec >= 5.0.1-                    , text       >= 0.2  && < 1.3-  default-language:   Haskell2010+benchmark bench-memory+    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 -source-repository head-  type:               git-  location:           https://github.com/mrkkrp/megaparsec.git+    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages++    else+        ghc-options: -O2 -Wall
− old-tests/Bugs.hs 
@@ -1,16 +0,0 @@-module Bugs (bugs) where--import Test.Framework--import qualified Bugs.Bug2-import qualified Bugs.Bug6-import qualified Bugs.Bug9-import qualified Bugs.Bug35-import qualified Bugs.Bug39--bugs :: [Test]-bugs = [ Bugs.Bug2.main-       , Bugs.Bug6.main-       , Bugs.Bug9.main-       , Bugs.Bug35.main-       , Bugs.Bug39.main ]
− old-tests/Bugs/Bug2.hs 
@@ -1,32 +0,0 @@-module Bugs.Bug2 (main) where--import Control.Applicative (empty)-import Control.Monad (void)--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--stringLiteral :: Parser String-stringLiteral = lexeme $ char '"' >> manyTill L.charLiteral (char '"')--main :: Test-main =-  testCase "Control Char Parsing (#2)" $-  parseString "\"test\\^Bstring\"" @?= "test\^Bstring"- where-   parseString :: String -> String-   parseString input =-      case parse stringLiteral "Example" input of-        Left{} -> error "Parse failure"-        Right str -> str
− old-tests/Bugs/Bug35.hs 
@@ -1,35 +0,0 @@-module Bugs.Bug35 (main) where--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--trickyFloats :: [String]-trickyFloats =-    [ "1.5339794352098402e-118"-    , "2.108934760892056e-59"-    , "2.250634744599241e-19"-    , "5.0e-324"-    , "5.960464477539063e-8"-    , "0.25996181067141905"-    , "0.3572019862807257"-    , "0.46817723004874223"-    , "0.9640035681058178"-    , "4.23808622486133"-    , "4.540362294799751"-    , "5.212384849884261"-    , "13.958257048123212"-    , "32.96176575630599"-    , "38.47735512322269" ]--testBatch :: Assertion-testBatch = mapM_ testFloat trickyFloats-  where testFloat x = parse (L.float :: Parser Double) "" x-          @?= Right (read x :: Double)--main :: Test-main = testCase "Output of Text.Megaparsec.Lexer.float (#35)" testBatch
− old-tests/Bugs/Bug39.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}--module Bugs.Bug39 (main) where--import Control.Applicative (empty)-import Control.Monad (void)-#if MIN_VERSION_base(4,7,0)-import Data.Either (isLeft, isRight)-#endif--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--#if !MIN_VERSION_base(4,7,0)-isRight, isLeft :: Either a b -> Bool-isRight (Right _) = True-isRight _         = False-isLeft  (Left _ ) = True-isLeft  _         = False-#endif--shouldFail :: [String]-shouldFail = [" 1", " +1", " -1"]--shouldSucceed :: [String]-shouldSucceed = ["1", "+1", "-1", "+ 1 ", "- 1 ", "1 "]--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--integer :: Parser Integer-integer = lexeme $ L.signed sc L.integer--testBatch :: Assertion-testBatch = mapM_ (f testFail)    shouldFail >>-            mapM_ (f testSucceed) shouldSucceed-    where f           t a = t (parse integer "" a) a-          testFail    x a = assertBool-                            ("Should fail on " ++ show a) (isLeft x)-          testSucceed x a = assertBool-                            ("Should succeed on " ++ show a) (isRight x)--main :: Test-main = testCase "Lexer should fail on leading whitespace (#39)" testBatch
− old-tests/Bugs/Bug6.hs 
@@ -1,22 +0,0 @@-module Bugs.Bug6 (main) where--import Text.Megaparsec-import Text.Megaparsec.String--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--import Util--main :: Test-main =-  testCase "Look-ahead preserving error location (#6)" $-  parseErrors variable "return" @?= ["'return' is a reserved keyword"]--variable :: Parser String-variable = do-  x <- lookAhead (some letterChar)-  if x == "return"-    then fail "'return' is a reserved keyword"-    else string x
− old-tests/Bugs/Bug9.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}--module Bugs.Bug9 (main) where--import Control.Applicative (empty)-import Control.Monad (void)--import Text.Megaparsec-import Text.Megaparsec.Expr-import Text.Megaparsec.String (Parser)-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<$))-#endif--data Expr = Const Integer | Op Expr Expr deriving Show--main :: Test-main =-  testCase "Tracing of current position in error message (#9)"-  $ result @?= ["unexpected '>'", "expecting end of input or operator"]-  where-    result :: [String]-    result = parseErrors parseTopLevel "4 >> 5"---- Syntax analysis--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--integer :: Parser Integer-integer = lexeme L.integer--operator :: String -> Parser String-operator = L.symbol sc--parseTopLevel :: Parser Expr-parseTopLevel = parseExpr <* eof--parseExpr :: Parser Expr-parseExpr = makeExprParser (Const <$> integer) table-  where table = [[ InfixL (Op <$ operator ">>>") ]]
− old-tests/Main.hs 
@@ -1,6 +0,0 @@-import Test.Framework--import Bugs (bugs)--main :: IO ()-main = defaultMain [testGroup "Bugs" bugs]
− old-tests/Util.hs 
@@ -1,12 +0,0 @@-module Util where--import Text.Megaparsec-import Text.Megaparsec.String (Parser)---- | Returns the error messages associated with a failed parse.--parseErrors :: Parser a -> String -> [String]-parseErrors p input =-  case parse p "" input of-    Left err -> drop 1 $ lines $ parseErrorPretty err-    Right _  -> []
− tests/Char.hs 
@@ -1,246 +0,0 @@------ QuickCheck tests for Megaparsec's character parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Char (tests) where--import Data.Char-import Data.List (findIndex, isPrefixOf)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Error--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--tests :: Test-tests = testGroup "Character parsers"-  [ testProperty "newline"         prop_newline-  , testProperty "crlf"            prop_crlf-  , testProperty "eol"             prop_eol-  , testProperty "tab"             prop_tab-  , testProperty "space"           prop_space-  , testProperty "controlChar"     prop_controlChar-  , testProperty "spaceChar"       prop_spaceChar-  , testProperty "upperChar"       prop_upperChar-  , testProperty "lowerChar"       prop_lowerChar-  , testProperty "letterChar"      prop_letterChar-  , testProperty "alphaNumChar"    prop_alphaNumChar-  , testProperty "printChar"       prop_printChar-  , testProperty "digitChar"       prop_digitChar-  , testProperty "hexDigitChar"    prop_hexDigitChar-  , testProperty "octDigitChar"    prop_octDigitChar-  , testProperty "markChar"        prop_markChar-  , testProperty "numberChar"      prop_numberChar-  , testProperty "punctuationChar" prop_punctuationChar-  , testProperty "symbolChar"      prop_symbolChar-  , testProperty "separatorChar"   prop_separatorChar-  , testProperty "asciiChar"       prop_asciiChar-  , testProperty "latin1Char"      prop_latin1Char-  , testProperty "charCategory"    prop_charCategory-  , testProperty "char"            prop_char-  , testProperty "char'"           prop_char'-  , testProperty "anyChar"         prop_anyChar-  , testProperty "oneOf"           prop_oneOf-  , testProperty "oneOf'"          prop_oneOf'-  , testProperty "noneOf"          prop_noneOf-  , testProperty "noneOf'"         prop_noneOf'-  , testProperty "string"          prop_string-  , testProperty "string'"         prop_string'_0-  , testProperty "string' (case)"  prop_string'_1 ]--instance Arbitrary GeneralCategory where-  arbitrary = elements [minBound..maxBound]--prop_newline :: String -> Property-prop_newline = checkChar newline (== '\n') (tkn '\n')--prop_crlf :: String -> Property-prop_crlf = checkString crlf "\r\n" (==)--prop_eol :: String -> Property-prop_eol s = checkParser eol r s-  where h = head s-        r | s == "\n"   = Right "\n"-          | s == "\r\n" = Right "\r\n"-          | null s      = posErr 0 s [ueof, elabel "end of line"]-          | h == '\n'   = posErr 1 s [utok (s !! 1), eeof]-          | h /= '\r'   = posErr 0 s [utok h, elabel "end of line"]-          | "\r\n" `isPrefixOf` s = posErr 2 s [utok (s !! 2), eeof]-          | otherwise   = posErr 0 s [ utoks (take 2 s)-                                     , utok '\r'-                                     , elabel "end of line" ]--prop_tab :: String -> Property-prop_tab = checkChar tab (== '\t') (tkn '\t')--prop_space :: String -> Property-prop_space s = checkParser space r s-  where r = case findIndex (not . isSpace) s of-              Just x  ->-                  let ch = s !! x-                  in posErr x s-                     [ utok ch-                     , utok ch-                     , elabel "white space"-                     , eeof ]-              Nothing -> Right ()--prop_controlChar :: String -> Property-prop_controlChar = checkChar controlChar isControl (lbl "control character")--prop_spaceChar :: String -> Property-prop_spaceChar = checkChar spaceChar isSpace (lbl "white space")--prop_upperChar :: String -> Property-prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter")--prop_lowerChar :: String -> Property-prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter")--prop_letterChar :: String -> Property-prop_letterChar = checkChar letterChar isAlpha (lbl "letter")--prop_alphaNumChar :: String -> Property-prop_alphaNumChar = checkChar alphaNumChar isAlphaNum-  (lbl "alphanumeric character")--prop_printChar :: String -> Property-prop_printChar = checkChar printChar isPrint (lbl "printable character")--prop_digitChar :: String -> Property-prop_digitChar = checkChar digitChar isDigit (lbl "digit")--prop_octDigitChar :: String -> Property-prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit")--prop_hexDigitChar :: String -> Property-prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit")--prop_markChar :: String -> Property-prop_markChar = checkChar markChar isMark (lbl "mark character")--prop_numberChar :: String -> Property-prop_numberChar = checkChar numberChar isNumber (lbl "numeric character")--prop_punctuationChar :: String -> Property-prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation")--prop_symbolChar :: String -> Property-prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol")--prop_separatorChar :: String -> Property-prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator")--prop_asciiChar :: String -> Property-prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character")--prop_latin1Char :: String -> Property-prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character")--prop_charCategory :: GeneralCategory -> String -> Property-prop_charCategory cat = checkChar (charCategory cat) p (lbl $ categoryName cat)-  where p c = generalCategory c == cat--prop_char :: Char -> String -> Property-prop_char c = checkChar (char c) (== c) (tkn c)--prop_char' :: Char -> String -> Property-prop_char' c s = checkParser (char' c) r s-  where h = head s-        l | isLower c = [c, toUpper c]-          | isUpper c = [c, toLower c]-          | otherwise = [c]-        r | null s         = posErr 0 s $ ueof : (etok <$> l)-          | length s == 1 && (h `elemi` l) = Right h-          | h `notElemi` l = posErr 0 s $ utok h : (etok <$> l)-          | otherwise      = posErr 1 s [utok (s !! 1), eeof]--prop_anyChar :: String -> Property-prop_anyChar = checkChar anyChar (const True) (lbl "character")--prop_oneOf :: String -> String -> Property-prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing--prop_oneOf' :: String -> String -> Property-prop_oneOf' a = checkChar (oneOf' a) (`elemi` a) Nothing--prop_noneOf :: String -> String -> Property-prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing--prop_noneOf' :: String -> String -> Property-prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing--prop_string :: String -> String -> Property-prop_string a = checkString (string a) a (==)--prop_string'_0 :: String -> String -> Property-prop_string'_0 a = checkString (string' a) a casei---- | 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--prop_string'_1 :: String -> Property-prop_string'_1 a = forAll (fuzzyCase a) $ \s ->-  checkString (string' a) a casei s---- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toLower x == toLower 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--tkn :: Char -> Maybe (ErrorItem Char)-tkn = Just . Tokens . (:|[])--lbl :: String -> Maybe (ErrorItem Char)-lbl = Just . Label . NE.fromList
− tests/Combinator.hs 
@@ -1,233 +0,0 @@------ QuickCheck tests for Megaparsec's generic parser combinators.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Combinator (tests) where--import Control.Applicative-import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator--import Util--tests :: Test-tests = testGroup "Generic parser combinators"-  [ testProperty "combinator between"   prop_between-  , testProperty "combinator choice"    prop_choice-  , testProperty "combinator count"     prop_count-  , testProperty "combinator count'"    prop_count'-  , testProperty "combinator eitherP"   prop_eitherP-  , testProperty "combinator endBy"     prop_endBy-  , testProperty "combinator endBy1"    prop_endBy1-  , testProperty "combinator manyTill"  prop_manyTill-  , testProperty "combinator someTill"  prop_someTill-  , testProperty "combinator option"    prop_option-  , testProperty "combinator sepBy"     prop_sepBy-  , testProperty "combinator sepBy1"    prop_sepBy1-  , testProperty "combinator sepEndBy"  prop_sepEndBy-  , testProperty "combinator sepEndBy1" prop_sepEndBy1-  , testProperty "combinator skipMany"  prop_skipMany-  , testProperty "combinator skipSome"  prop_skipSome ]--prop_between :: String -> Char -> NonNegative Int -> String -> Property-prop_between pre c n' post = checkParser p r s-  where p = between (string pre) (string post) (many (char c))-        n = getNonNegative n'-        b = length $ takeWhile (== c) post-        r | b > 0 = posErr (length pre + n + b) s $ etoks post : etok c :-            [if length post == b-              then ueof-              else utoks [post !! b]]-          | otherwise = Right z-        z = replicate n c-        s = pre ++ z ++ post--prop_choice :: NonEmptyList Char -> Char -> Property-prop_choice cs' s' = checkParser p r s-  where cs = getNonEmpty cs'-        p = choice $ char <$> cs-        r | s' `elem` cs = Right s'-          | otherwise    = posErr 0 s $ utok s' : (etok <$> cs)-        s = [s']--prop_count :: Int -> NonNegative Int -> Property-prop_count n x' = checkParser p r s-  where x = getNonNegative x'-        p = count n (char 'x')-        r = simpleParse (count' n n (char 'x')) s-        s = replicate x 'x'--prop_count' :: Int -> Int -> NonNegative Int -> Property-prop_count' m n x' = checkParser p r s-  where x = getNonNegative x'-        p = count' m n (char 'x')-        r | n <= 0 || m > n  =-              if x == 0-                then Right ""-                else posErr 0 s [utok 'x', eeof]-          | m <= x && x <= n = Right s-          | x < m            = posErr x s [ueof, etok 'x']-          | otherwise        = posErr n s [utok 'x', eeof]-        s = replicate x 'x'--prop_eitherP :: Char -> Property-prop_eitherP ch = checkParser p r s-  where p = eitherP letterChar digitChar-        r | isLetter ch = Right (Left  ch)-          | isDigit  ch = Right (Right ch)-          | otherwise   = posErr 0 s [utok ch, elabel "letter", elabel "digit"]-        s = pure ch--prop_endBy :: NonNegative Int -> Char -> Property-prop_endBy n' c = checkParser p r s-  where n = getNonNegative n'-        p = endBy (char 'a') (char '-')-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a', eeof]-          | c /= '-'           = posErr (g n) s $ utok c :-            (if n > 0 then etok '-' else eeof) :-            [etok 'a' | n == 0]-          | otherwise = Right (replicate n 'a')-        s = intersperse '-' (replicate n 'a') ++ [c]--prop_endBy1 :: NonNegative Int -> Char -> Property-prop_endBy1 n' c = checkParser p r s-  where n = getNonNegative n'-        p = endBy1 (char 'a') (char '-')-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a']-          | c /= '-'           = posErr (g n) s $ utok c :-            [etok '-' | n > 0] ++ [etok 'a' | n == 0]-          | otherwise = Right (replicate n 'a')-        s = intersperse '-' (replicate n 'a') ++ [c]--prop_manyTill :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_manyTill a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar-        r | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]-          | otherwise = let (pre, post) = break (== 'c') s-                        in Right (pre, drop 1 post)-        s = abcRow a b c--prop_someTill :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_someTill a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar-        r | null s    = posErr 0 s [ueof, elabel "letter"]-          | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]-          | s == "c"  = posErr 1 s [ueof, etok 'c', elabel "letter"]-          | head s == 'c' = Right ("c", drop 2 s)-          | otherwise = let (pre, post) = break (== 'c') s-                        in Right (pre, drop 1 post)-        s = abcRow a b c--prop_option :: String -> String -> String -> Property-prop_option d a s = checkParser p r s-  where p = option d (string a)-        r = simpleParse (fromMaybe d <$> optional (string a)) s--prop_sepBy :: NonNegative Int -> Maybe Char -> Property-prop_sepBy n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepBy (char 'a') (char '-')-        r | isNothing c' = Right (replicate n 'a')-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]-          | c == '-'  = posErr (length s) s [ueof, etok 'a']-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepBy1 :: NonNegative Int -> Maybe Char -> Property-prop_sepBy1 n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepBy1 (char 'a') (char '-')-        r | isNothing c' && n >= 1 = Right (replicate n 'a')-          | isNothing c' = posErr 0 s [ueof, etok 'a']-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a']-          | c == '-'  = posErr (length s) s [ueof, etok 'a']-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepEndBy :: NonNegative Int -> Maybe Char -> Property-prop_sepEndBy n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy (char 'a') (char '-')-        a = Right $ replicate n 'a'-        r | isNothing c' = a-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]-          | c == '-'  = a-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepEndBy1 :: NonNegative Int -> Maybe Char -> Property-prop_sepEndBy1 n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy1 (char 'a') (char '-')-        a = Right $ replicate n 'a'-        r | isNothing c' && n >= 1 = a-          | isNothing c' = posErr 0 s [ueof, etok 'a']-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a']-          | c == '-'  = a-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_skipMany :: Char -> NonNegative Int -> String -> Property-prop_skipMany c n' a = checkParser p r s-  where p = skipMany (char c) *> string a-        n = getNonNegative n'-        r = simpleParse (many (char c) >> string a) s-        s = replicate n c ++ a--prop_skipSome :: Char -> NonNegative Int -> String -> Property-prop_skipSome c n' a = checkParser p r s-  where p = skipSome (char c) *> string a-        n = getNonNegative n'-        r = simpleParse (some (char c) >> string a) s-        s = replicate n c ++ a--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0
− tests/Error.hs 
@@ -1,152 +0,0 @@------ QuickCheck tests for Megaparsec's parse errors.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Error (tests) where--import Data.Function (on)-import Data.List (isInfixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid ((<>))-import Data.Set (Set)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion, (@?=))-import Test.QuickCheck--import Text.Megaparsec.Error-import Text.Megaparsec.Pos--import Util ()--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable, all)-import Data.Monoid (mempty)-import Prelude hiding (all)-#endif--tests :: Test-tests = testGroup "Parse errors"-  [ testProperty "monoid left identity"               prop_monoid_left_id-  , testProperty "monoid right identity"              prop_monoid_right_id-  , testProperty "monoid associativity"               prop_monoid_assoc-  , testProperty "consistency of Show/Read"           prop_showReadConsistency-  , testProperty "position of merged error"           prop_mergeErrorPos-  , testProperty "unexpected items in merged error"   prop_mergeErrorUnexpected-  , testProperty "expected items in merged error"     prop_mergeErrorExpected-  , testProperty "custom items in merged error"       prop_mergeErrorCustom-  , testCase     "showTokens (String instance)"       case_showTokens-  , testCase     "rendering of unknown parse error"   case_ppUnknownError-  , testProperty "source position in rendered error"  prop_ppSourcePos-  , testProperty "unexpected items in rendered error" prop_ppUnexpected-  , testProperty "expected items in rendered error"   prop_ppExpected-  , testProperty "custom data in rendered error"      prop_ppCustom ]--type PE = ParseError Char Dec--prop_monoid_left_id :: PE -> Property-prop_monoid_left_id x = mempty <> x === x .&&.-  mempty { errorPos = errorPos x } <> x === x--prop_monoid_right_id :: PE -> Property-prop_monoid_right_id x = x <> mempty === x .&&.-  mempty { errorPos = errorPos x } <> x === x--prop_monoid_assoc :: PE -> PE -> PE -> Property-prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z)--prop_showReadConsistency :: PE -> Property-prop_showReadConsistency x = read (show x) === x--prop_mergeErrorPos :: PE -> PE -> Property-prop_mergeErrorPos e1 e2 =-  errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2)--prop_mergeErrorUnexpected :: PE -> PE -> Property-prop_mergeErrorUnexpected = checkMergedItems errorUnexpected--prop_mergeErrorExpected :: PE -> PE -> Property-prop_mergeErrorExpected = checkMergedItems errorExpected--prop_mergeErrorCustom :: PE -> PE -> Property-prop_mergeErrorCustom = checkMergedItems errorCustom--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--case_showTokens :: Assertion-case_showTokens = mapM_ (\(x,y) -> showTokens (NE.fromList x) @?= y)-  [ ("\r\n", "crlf newline")-  , ("\0",   "null")-  , ("\a",   "bell")-  , ("\b",   "backspace")-  , ("\t",   "tab")-  , ("\n",   "newline")-  , ("\v",   "vertical tab")-  , ("\f",   "form feed")-  , ("\r",   "carriage return")-  , (" ",    "space")-  , ("a",    "'a'")-  , ("foo",  "\"foo\"") ]--case_ppUnknownError :: Assertion-case_ppUnknownError =-  parseErrorPretty (err :: PE) @?= "1:1:\nunknown parse error\n"-  where-    err = ParseError-      { errorPos        = initialPos "" :| []-      , errorUnexpected = E.empty-      , errorExpected   = E.empty-      , errorCustom     = E.empty }--prop_ppSourcePos :: PE -> Property-prop_ppSourcePos = checkPresence errorPos sourcePosPretty--prop_ppUnexpected :: PE -> Property-prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent--prop_ppExpected :: PE -> Property-prop_ppExpected = checkPresence errorExpected showErrorComponent--prop_ppCustom :: PE -> Property-prop_ppCustom = checkPresence errorCustom showErrorComponent--checkPresence :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property-checkPresence g r e = property (all f (g e))-  where rendered = parseErrorPretty e-        f x = r x `isInfixOf` rendered
− tests/Expr.hs 
@@ -1,189 +0,0 @@------ QuickCheck tests for Megaparsec's expression parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}--module Expr (tests) where--import Control.Applicative (some, (<|>))-import Data.Char (isDigit, digitToInt)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Expr-import Text.Megaparsec.Prim--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)-#endif--tests :: Test-tests = testGroup "Expression parsers"-  [ testProperty "correctness of expression parser" prop_correctness-  , testProperty "error message on empty input"     prop_empty_error-  , testProperty "error message on missing term"    prop_missing_term-  , testProperty "error message on missing op"      prop_missing_op ]---- 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 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)] ]--prop_correctness :: Node -> Property-prop_correctness node = checkParser expr (Right node) (showNode node)--prop_empty_error :: Property-prop_empty_error = checkParser expr r s-  where r = posErr 0 s [ueof, elabel "term"]-        s = ""--prop_missing_term :: Char -> Property-prop_missing_term c = checkParser expr r s-  where r | c `elem` "-(" = posErr 1 s [ueof, elabel "term"]-          | isDigit c     = Right . Val . fromIntegral . digitToInt $ c-          | otherwise     = posErr 0 s [utok c, elabel "term"]-        s = pure c--prop_missing_op :: Node -> Node -> Property-prop_missing_op a b = checkParser expr r s-  where a' = inParens a-        c = s !! n-        n = succ $ length a'-        r | c == '-'  = Right $ Sub a b-          | otherwise = posErr n s [utok c, eeof, elabel "operator"]-        s = a' ++ " " ++ inParens b
− tests/Lexer.hs 
@@ -1,402 +0,0 @@------ QuickCheck tests for Megaparsec's lexer.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE TypeFamilies     #-}--module Lexer (tests) where--import Control.Applicative (empty)-import Control.Monad (void)-import Data.Char-  ( readLitChar-  , showLitChar-  , isDigit-  , isAlphaNum-  , isSpace-  , toLower )-import Data.List (findIndices, isInfixOf, find)-import Data.Maybe-import Data.Scientific (fromFloatDigits)-import Numeric (showInt, showHex, showOct, showSigned)--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion)-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--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<*>), (<$))-#endif--tests :: Test-tests = testGroup "Lexer"-  [ testProperty "space combinator"       prop_space-  , testProperty "symbol combinator"      prop_symbol-  , testProperty "symbol' combinator"     prop_symbol'-  , testCase     "skipBlockCommentNested" case_skipBlockCommentNested-  , testProperty "indentLevel"            prop_indentLevel-  , testProperty "incorrectIndent"        prop_incorrectIndent-  , testProperty "indentGuard combinator" prop_indentGuard-  , testProperty "nonIndented combinator" prop_nonIndented-  , testProperty "indentBlock combinator" prop_indentBlock-  , testProperty "indentBlock (many)"     prop_indentMany-  , testProperty "lineFold"               prop_lineFold-  , testProperty "charLiteral"            prop_charLiteral-  , testProperty "integer"                prop_integer-  , testProperty "decimal"                prop_decimal-  , testProperty "hexadecimal"            prop_hexadecimal-  , testProperty "octal"                  prop_octal-  , testProperty "float 0"                prop_float_0-  , testProperty "float 1"                prop_float_1-  , testProperty "number 0"               prop_number_0-  , testProperty "number 1"               prop_number_1-  , testProperty "number 2 (signed)"      prop_number_2-  , testProperty "signed"                 prop_signed ]---- White space--mkWhiteSpace :: Gen String-mkWhiteSpace = concat <$> listOf whiteUnit-  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]--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 "/*" "*/"--prop_space :: Property-prop_space = forAll mkWhiteSpace (checkParser p r)-  where p = scn-        r = Right ()--prop_symbol :: Maybe Char -> Property-prop_symbol t = forAll mkSymbol $ \s ->-  parseSymbol (symbol scn) id s t--prop_symbol' :: Maybe Char -> Property-prop_symbol' t = forAll mkSymbol $ \s ->-  parseSymbol (symbol' scn) (fmap toLower) s t--parseSymbol-  :: (String -> Parser String)-  -> (String -> String)-  -> String-  -> Maybe Char-  -> Property-parseSymbol p' f s' t = checkParser p r s-  where p = p' (f g)-        r | g == s || isSpace (last s) = Right g-          | otherwise = posErr (length s - 1) s [utok (last s), eeof]-        g = takeWhile (not . isSpace) s-        s = s' ++ maybeToList t--case_skipBlockCommentNested :: Assertion-case_skipBlockCommentNested = checkCase p r s-  where p = space (void C.spaceChar) empty-              (skipBlockCommentNested "/*" "*/") <* eof-        r = Right ()-        s = " /* foo bar /* baz */ quux */ "---- Indentation--prop_indentLevel :: SourcePos -> Property-prop_indentLevel pos = p /=\ sourceColumn pos-  where p = setPosition pos >> indentLevel--prop_incorrectIndent :: Ordering -> Pos -> Pos -> Property-prop_incorrectIndent ord ref actual = checkParser p r s-  where p = incorrectIndent ord ref actual :: Parser ()-        r = posErr 0 s (ii ord ref actual)-        s = ""--prop_indentGuard :: NonNegative (Small Int) -> Property-prop_indentGuard n =-  forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) ->-    let r | col0 <= pos1 = posErr 0 s (ii GT pos1 col0)-          | col1 /= col0 = posErr (getIndent l1 + g 1) s (ii EQ col0 col1)-          | col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2)-          | otherwise    = Right ()-        (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-        fragments = [l0,l1,l2]-        g x = sum (length <$> take x fragments)-        s = concat fragments-    in checkParser p r s-  where mki = mkIndent sbla (getSmall $ getNonNegative n)-        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)--prop_nonIndented :: Property-prop_nonIndented = forAll (mkIndent sbla 0) $ \s ->-  let i = getIndent s-      r | i == 0    = Right sbla-        | otherwise = posErr i s (ii EQ pos1 (getCol s))-  in checkParser p r s-  where p = nonIndented scn (symbol scn sbla)--prop_indentBlock :: Maybe (Positive (Small Int)) -> Property-prop_indentBlock mn'' = forAll mkBlock $ \(l0,l1,l2,l3,l4) ->-  let r | col1 <= col0 =-          posErr (getIndent l1 + g 1) s [utok (head sblb), eeof]-        | isJust mn && col1 /= ib' =-          posErr (getIndent l1 + g 1) s (ii EQ ib' col1)-        | col2 <= col1 =-          posErr (getIndent l2 + g 2) s (ii GT col1 col2)-        | col3 == col2 =-          posErr (getIndent l3 + g 3) s [utok (head sblb), etoks sblc]-        | col3 <= col0 =-          posErr (getIndent l3 + g 3) s [utok (head sblb), eeof]-        | col3 < col1 =-          posErr (getIndent l3 + g 3) s (ii EQ col1 col3)-        | col3 > col1 =-          posErr (getIndent l3 + g 3) s (ii EQ col2 col3)-        | col4 <= col3 =-          posErr (getIndent l4 + g 4) s (ii GT col3 col4)-        | otherwise = Right (sbla, [(sblb, [sblc]), (sblb, [sblc])])-      (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-  in checkParser p r s-  where 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)-        p = lvla-        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,)-        mn'  = getSmall . getPositive <$> mn''-        mn   = unsafePos . fromIntegral <$> mn'-        ib   = fromMaybe 2 mn'-        ib'  = unsafePos (fromIntegral ib)--prop_indentMany :: Property-prop_indentMany = forAll (mkIndent sbla 0) (checkParser p r)-  where r = Right (sbla, [])-        p = lvla-        lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-        lvlb = b sblb-        b    = symbol sc-        l x  = return . (x,)--prop_lineFold :: Property-prop_lineFold = forAll mkFold $ \(l0,l1,l2) ->-  let r | end0 && col1 <= col0 =-          posErr (getIndent l1 + g 1) s (ii GT col0 col1)-        | end1 && col2 <= col0 =-          posErr (getIndent l2 + g 2) s (ii GT col0 col2)-        | otherwise = Right (sbla, sblb, sblc)-      (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-      (end0, end1)       = (getEnd l0, getEnd l1)-      fragments = [l0,l1,l2]-      g x = sum (length <$> take x fragments)-      s = concat fragments-  in checkParser p r s-  where-    mkFold = do-      l0 <- mkInterspace sbla 0-      l1 <- mkInterspace sblb 1-      l2 <- mkInterspace sblc 1-      return (l0,l1,l2)-    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'--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]-ii ord ref actual = [cstm (DecIndentation ord ref actual)]--pos1 :: Pos-pos1 = unsafePos 1---- Character and string literals--prop_charLiteral :: String -> Bool -> Property-prop_charLiteral t i = checkParser charLiteral r s-  where b = listToMaybe $ readLitChar s-        (h, g) = fromJust b-        r | isNothing b = posErr 0 s $ elabel "literal character" :-            [ if null s then ueof else utok (head s) ]-          | null g      = Right h-          | otherwise   = posErr l s [utok (head g), eeof]-        l = length s - length g-        s = if null t || i then t else showLitChar (head t) (tail t)---- Numbers--prop_integer :: NonNegative Integer -> Int -> Property-prop_integer n' i = checkParser integer r s-  where (r, s) = quasiCorrupted n' i showInt "integer"--prop_decimal :: NonNegative Integer -> Int -> Property-prop_decimal n' i = checkParser decimal r s-  where (r, s) = quasiCorrupted n' i showInt "decimal integer"--prop_hexadecimal :: NonNegative Integer -> Int -> Property-prop_hexadecimal n' i = checkParser hexadecimal r s-  where (r, s) = quasiCorrupted n' i showHex "hexadecimal integer"--prop_octal :: NonNegative Integer -> Int -> Property-prop_octal n' i = checkParser octal r s-  where (r, s) = quasiCorrupted n' i showOct "octal integer"--prop_float_0 :: NonNegative Double -> Property-prop_float_0 n' = checkParser float r s-  where n = getNonNegative n'-        r = Right n-        s = show n--prop_float_1 :: Maybe (NonNegative Integer) -> Property-prop_float_1 n' = checkParser float r s-  where r | isNothing n' = posErr 0 s [ueof, elabel "floating point number"]-          | otherwise    = posErr (length s) s-            [ueof, etok '.', etok 'E', etok 'e', elabel "digit"]-        s = maybe "" (show . getNonNegative) n'--prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property-prop_number_0 n' = checkParser number r s-  where r = Right $ case n' of-              Left  x -> fromIntegral . getNonNegative $ x-              Right x -> fromFloatDigits . getNonNegative $ x-        s = either (show . getNonNegative) (show . getNonNegative) n'--prop_number_1 :: Property-prop_number_1 = checkParser number r s-  where r = posErr 0 s [ueof, elabel "number"]-        s = ""--prop_number_2 :: Either Integer Double -> Property-prop_number_2 n = checkParser p r s-  where p = signed (hidden C.space) number-        r = Right $ case n of-              Left  x -> fromIntegral x-              Right x -> fromFloatDigits x-        s = either show show n--prop_signed :: Integer -> Int -> Bool -> Property-prop_signed n i plus = checkParser p r s-  where p = signed (hidden C.space) integer-        r | i > length z = Right n-          | otherwise = posErr i s $ utok '?' :-            (if i <= 0 then [etok '+', etok '-'] else []) ++-            [elabel $ if isNothing . find isDigit $ take i s-                        then "integer"-                        else "rest of integer"] ++-            [eeof | i > head (findIndices isDigit s)]-        z = let bar = showSigned showInt 0 n ""-            in if n < 0 || plus then bar else '+' : bar-        s = if i <= length z then take i z ++ "?" ++ drop i z else z--quasiCorrupted-  :: NonNegative Integer-  -> Int-  -> (Integer -> String -> String)-  -> String-  -> (Either (ParseError Char Dec) Integer, String)-quasiCorrupted n' i shower l = (r, s)-  where n = getNonNegative n'-        r | i > length z = Right n-          | otherwise    = posErr i s $ utok '?' :-            [ eeof | i > 0 ] ++-            [if i <= 0 || null l-               then elabel l-               else elabel $ "rest of " ++ l]-        z = shower n ""-        s = if i <= length z then take i z ++ "?" ++ drop i z else z
− tests/Main.hs 
@@ -1,51 +0,0 @@------ QuickCheck tests for Megaparsec, main module.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Main (main) where--import Test.Framework (defaultMain)--import qualified Pos-import qualified Error-import qualified Prim-import qualified Combinator-import qualified Char-import qualified Expr-import qualified Perm-import qualified Lexer--main :: IO ()-main = defaultMain-  [ Pos.tests-  , Error.tests-  , Prim.tests-  , Combinator.tests-  , Char.tests-  , Expr.tests-  , Perm.tests-  , Lexer.tests ]
− tests/Perm.hs 
@@ -1,103 +0,0 @@------ QuickCheck tests for Megaparsec's permutation phrases parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Perm (tests) where--import Control.Applicative-import Data.List (nub, elemIndices)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Lexer (integer)-import Text.Megaparsec.Perm--import Util--tests :: Test-tests = testGroup "Permutation phrases parsers"-  [ testProperty "permutation parser pure" prop_pure-  , testProperty "permutation test 0"      prop_perm_0-  , testProperty "combinator (<$$>)"       prop_ddcomb ]--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--prop_pure :: Integer -> Property-prop_pure n = makePermParser p /=\ n-  where p = id <$?> (succ n, pure n)--prop_perm_0 :: String -> Char -> CharRows -> Property-prop_perm_0 a' c' v = checkParser (makePermParser p) r s-  where (a,b,c) = getChars v-        p = (,,) <$?> (a', some (char a))-                 <||> char b-                 <|?> (c', char c)-        r | length bis > 1 && (length cis <= 1 || head bis < head cis) =-              posErr (bis !! 1) s $ [utok b, eeof] ++-              [etok a | a `notElem` preb] ++-              [etok c | c `notElem` preb]-          | length cis > 1 =-            posErr (cis !! 1) s $ [utok c] ++-            [etok a | a `notElem` prec] ++-            [if b `elem` prec then eeof else etok b]-          | b `notElem` s = posErr (length s) s $ [ueof, etok b] ++-                            [etok a | a `notElem` s || last s == a] ++-                            [etok c | c `notElem` s]-          | otherwise = Right ( if a `elem` s then filter (== a) s else a'-                              , b-                              , if c `elem` s then c else c' )-        bis  = elemIndices b s-        preb = take (bis !! 1) s-        cis  = elemIndices c s-        prec = take (cis !! 1) s-        s    = getInput v--prop_ddcomb :: NonNegative Integer -> Property-prop_ddcomb n' = checkParser (makePermParser p) r s-  where p = succ <$$> integer-        r = Right (succ n)-        n = getNonNegative n'-        s = show n
− tests/Pos.hs 
@@ -1,121 +0,0 @@------ QuickCheck tests for Megaparsec's textual source positions.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Pos (tests) where--import Control.Monad.Catch-import Data.Function (on)-import Data.List (isInfixOf, elemIndices)-import Data.Semigroup ((<>))--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Pos-import Util (updatePosString)--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif--tests :: Test-tests = testGroup "Textual source positions"-  [ testProperty "creation of Pos (mkPos)"              prop_mkPos-  , testProperty "creation of Pos (unsafePos)"          prop_unsafePos-  , testProperty "consistency of Show/Read for Pos"     prop_showReadPos-  , testProperty "Ord instance of Pos"                  prop_ordPos-  , testProperty "Semigroup instance of Pos"            prop_semigroupPos-  , testProperty "construction of initial position"     prop_initialPos-  , testProperty "consistency of Show/Read for SourcePos" prop_showReadSourcePos-  , testProperty "pretty-printing: visible file path"   prop_ppFilePath-  , testProperty "pretty-printing: visible line"        prop_ppLine-  , testProperty "pretty-printing: visible column"      prop_ppColumn-  , testProperty "default updating of source position"  prop_defaultUpdatePos ]--prop_mkPos :: Word -> Property-prop_mkPos x' = case mkPos x' of-  Left  e -> fromException e === Just InvalidPosException-  Right x -> unPos x === x'--prop_unsafePos :: Positive Word -> Property-prop_unsafePos x' = unPos (unsafePos x) === x-  where x = getPositive x'--prop_showReadPos :: Pos -> Property-prop_showReadPos x = read (show x) === x--prop_ordPos :: Pos -> Pos -> Property-prop_ordPos x y = compare x y === (compare `on` unPos) x y--prop_semigroupPos :: Pos -> Pos -> Property-prop_semigroupPos x y =-  x <> y === unsafePos (unPos x + unPos y) .&&.-  unPos (x <> y) === unPos x + unPos y--prop_initialPos :: String -> Property-prop_initialPos fp =-  sourceName   x === fp          .&&.-  sourceLine   x === unsafePos 1 .&&.-  sourceColumn x === unsafePos 1-  where x = initialPos fp--prop_showReadSourcePos :: SourcePos -> Property-prop_showReadSourcePos x = read (show x) === x--prop_ppFilePath :: SourcePos -> Property-prop_ppFilePath x = property $-  sourceName x `isInfixOf` sourcePosPretty x--prop_ppLine :: SourcePos -> Property-prop_ppLine x = property $-  (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x--prop_ppColumn :: SourcePos -> Property-prop_ppColumn x = property $-  (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x--prop_defaultUpdatePos :: Pos -> SourcePos -> String -> Property-prop_defaultUpdatePos w pos "" = updatePosString w pos "" === pos-prop_defaultUpdatePos w pos s =-  sourceName updated === sourceName pos .&&.-  unPos (sourceLine updated) === unPos (sourceLine pos) + inclines .&&.-  cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` unPos w == 0))-  where-    updated  = updatePosString w pos s-    cols     = unPos (sourceColumn updated)-    newlines = elemIndices '\n' s-    inclines = fromIntegral (length newlines)-    total    = fromIntegral (length s)-    mincols  =-      if null newlines-        then total + unPos (sourceColumn pos)-        else total - fromIntegral (maximum newlines)
− tests/Prim.hs 
@@ -1,1017 +0,0 @@------ QuickCheck tests for Megaparsec's primitive parser combinators.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Prim (tests) where--import Control.Applicative-import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (isLetter, toUpper, chr)-import Data.Foldable (asum)-import Data.List (isPrefixOf, foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (maybeToList, fromMaybe)-import Data.Proxy-import Data.Set (Set)-import Data.Word (Word8)-import Prelude hiding (span)-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.Set                    as E-import qualified Data.Text                   as T-import qualified Data.Text.Lazy              as TL--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck hiding (label)-import Test.HUnit (Assertion)--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 Pos ()-import Error ()-import Util--tests :: Test-tests = testGroup "Primitive parser combinators"-  [ testProperty "Stream lazy byte string"             prop_byteStringL-  , testProperty "Stream lazy byte string (pos)"       prop_byteStringL_pos-  , testProperty "Stream strict byte string"           prop_byteStringS-  , testProperty "Stream strict byte string (pos)"     prop_byteStringS_pos-  , testProperty "Stream lazy text"                    prop_textL-  , testProperty "Stream lazy text (pos)"              prop_textL_pos-  , testProperty "Stream strict text"                  prop_textS-  , testProperty "Stream strict text (pos)"            prop_textS_pos-  , testProperty "position in custom stream, eof"      prop_cst_eof-  , testProperty "position in custom stream, token"    prop_cst_token-  , testProperty "position in custom stream, tokens"   prop_cst_tokens-  , testProperty "ParsecT functor"                     prop_functor-  , testProperty "ParsecT applicative (<*>)"           prop_applicative_0-  , testProperty "ParsecT applicative (<*>) meok-cerr" prop_applicative_1-  , testProperty "ParsecT applicative (*>)"            prop_applicative_2-  , testProperty "ParsecT applicative (<*)"            prop_applicative_3-  , testProperty "ParsecT alternative empty and (<|>)" prop_alternative_0-  , testProperty "ParsecT alternative (<|>)"           prop_alternative_1-  , testProperty "ParsecT alternative (<|>) pos"       prop_alternative_2-  , testProperty "ParsecT alternative (<|>) hints"     prop_alternative_3-  , testProperty "ParsecT alternative many"            prop_alternative_4-  , testProperty "ParsecT alternative some"            prop_alternative_5-  , testProperty "ParsecT alternative optional"        prop_alternative_6-  , testProperty "ParsecT monad return"                prop_monad_0-  , testProperty "ParsecT monad (>>)"                  prop_monad_1-  , testProperty "ParsecT monad (>>=)"                 prop_monad_2-  , testProperty "ParsecT monad fail"                  prop_monad_3-  , testProperty "ParsecT monad laws: left identity"   prop_monad_left_id-  , testProperty "ParsecT monad laws: right identity"  prop_monad_right_id-  , testProperty "ParsecT monad laws: associativity"   prop_monad_assoc-  , testProperty "ParsecT monad io (liftIO)"           prop_monad_io-  , testProperty "ParsecT monad reader ask"   prop_monad_reader_ask-  , testProperty "ParsecT monad reader local" prop_monad_reader_local-  , testProperty "ParsecT monad state get"    prop_monad_state_get-  , testProperty "ParsecT monad state put"    prop_monad_state_put-  , testProperty "ParsecT monad cont"         prop_monad_cont-  , testProperty "ParsecT monad error: throw" prop_monad_error_throw-  , testProperty "ParsecT monad error: catch" prop_monad_error_catch-  , testProperty "combinator unexpected"      prop_unexpected-  , testProperty "combinator failure"                  prop_failure-  , testProperty "combinator label"                    prop_label-  , testProperty "combinator hidden hints"             prop_hidden_0-  , testProperty "combinator hidden error"             prop_hidden_1-  , testProperty "combinator try"                      prop_try-  , testProperty "combinator lookAhead"                prop_lookAhead_0-  , testProperty "combinator lookAhead hints"          prop_lookAhead_1-  , testProperty "combinator lookAhead messages"       prop_lookAhead_2-  , testCase     "combinator lookAhead cerr"           case_lookAhead_3-  , testProperty "combinator notFollowedBy"       prop_notFollowedBy_0-  , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1-  , testProperty "combinator notFollowedBy eof"   prop_notFollowedBy_2-  , testCase     "combinator notFollowedBy cerr"  case_notFollowedBy_3a-  , testCase     "combinator notFollowedBy cerr"  case_notFollowedBy_3b-  , testCase     "combinator notFollowedBy eerr"  case_notFollowedBy_4a-  , testCase     "combinator notFollowedBy eerr"  case_notFollowedBy_4b-  , testProperty "combinator withRecovery"             prop_withRecovery_0-  , testCase     "combinator withRecovery eok"         case_withRecovery_1-  , testCase     "combinator withRecovery meerr-rcerr" case_withRecovery_2-  , testCase     "combinator withRecovery meerr-reok"  case_withRecovery_3a-  , testCase     "combinator withRecovery meerr-reok"  case_withRecovery_3b-  , testCase     "combinator withRecovery mcerr-rcok"  case_withRecovery_4a-  , testCase     "combinator withRecovery mcerr-rcok"  case_withRecovery_4b-  , testCase     "combinator withRecovery mcerr-rcerr" case_withRecovery_5-  , testCase     "combinator withRecovery mcerr-reok"  case_withRecovery_6a-  , testCase     "combinator withRecovery mcerr-reok"  case_withRecovery_6b-  , testCase     "combinator withRecovery mcerr-reerr" case_withRecovery_7-  , testCase     "combinator eof return value"    case_eof-  , testProperty "combinator token"                    prop_token-  , testProperty "combinator tokens"                   prop_tokens_0-  , testProperty "combinator tokens (consumption)"     prop_tokens_1-  , testProperty "parser state position"               prop_state_pos-  , testProperty "parser state position (push)"        prop_state_pushPosition-  , testProperty "parser state position (pop)"         prop_state_popPosition-  , testProperty "parser state input"                  prop_state_input-  , testProperty "parser state tab width"              prop_state_tab-  , testProperty "parser state general"                prop_state-  , testProperty "parseMaybe"                          prop_parseMaybe-  , testProperty "custom state parsing"                prop_runParser'-  , testProperty "custom state parsing (transformer)"  prop_runParserT'-  , testProperty "state on failure (mplus)"         prop_stOnFail_0-  , testProperty "state on failure (tab)"           prop_stOnFail_1-  , testProperty "state on failure (eof)"           prop_stOnFail_2-  , testProperty "state on failure (notFollowedBy)" prop_stOnFail_3-  , testProperty "ReaderT try"              prop_ReaderT_try-  , testProperty "ReaderT notFollowedBy"    prop_ReaderT_notFollowedBy-  , testProperty "StateT alternative (<|>)" prop_StateT_alternative-  , testProperty "StateT lookAhead"         prop_StateT_lookAhead-  , testProperty "StateT notFollowedBy"     prop_StateT_notFollowedBy-  , testProperty "WriterT"                  prop_WriterT ]--instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State-    <$> arbitrary-    <*> arbitrary-    <*> (unsafePos <$> choose (1, 20))---- Various instances of Stream--prop_byteStringL :: Word8 -> NonNegative Int -> Property-prop_byteStringL ch' n = parse p "" (BL.pack s) === Right s-  where p  = many (char ch) :: Parsec Dec BL.ByteString String-        s  = replicate (getNonNegative n) ch-        ch = byteToChar ch'--prop_byteStringL_pos :: Pos -> SourcePos -> Char -> Property-prop_byteStringL_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy BL.ByteString) w pos ch--prop_byteStringS :: Word8 -> NonNegative Int -> Property-prop_byteStringS ch' n = parse p "" (B.pack s) === Right s-  where p  = many (char ch) :: Parsec Dec B.ByteString String-        s  = replicate (getNonNegative n) ch-        ch = byteToChar ch'--prop_byteStringS_pos :: Pos -> SourcePos -> Char -> Property-prop_byteStringS_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy B.ByteString) w pos ch--byteToChar :: Word8 -> Char-byteToChar = chr . fromIntegral--prop_textL :: Char -> NonNegative Int -> Property-prop_textL ch n = parse p "" (TL.pack s) === Right s-  where p = many (char ch) :: Parsec Dec TL.Text String-        s = replicate (getNonNegative n) ch--prop_textL_pos :: Pos -> SourcePos -> Char -> Property-prop_textL_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy TL.Text) w pos ch--prop_textS :: Char -> NonNegative Int -> Property-prop_textS ch n = parse p "" (T.pack s) === Right s-  where p = many (char ch) :: Parsec Dec T.Text String-        s = replicate (getNonNegative n) ch--prop_textS_pos :: Pos -> SourcePos -> Char -> Property-prop_textS_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy T.Text) w pos ch---- Custom stream of tokens and position advancing---- | This data type will represent tokens in input stream for the purposes--- of next several tests.--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 <$> arbitrary--type CustomParser = Parsec Dec [Span]--prop_cst_eof :: State [Span] -> Property-prop_cst_eof st =-  (not . null . stateInput) st ==> (runParser' p st === r)-  where-    p = eof :: CustomParser ()-    h = head (stateInput st)-    apos = let (_:|z) = statePos st in spanStart h :| z-    r = (st { statePos = apos }, Left ParseError-      { errorPos        = apos-      , errorUnexpected = E.singleton (Tokens (nes h))-      , errorExpected   = E.singleton EndOfInput-      , errorCustom     = E.empty })--prop_cst_token :: State [Span] -> Span -> Property-prop_cst_token st@State {..} span = runParser' p st === r-  where-    p = pSpan span-    h = head stateInput-    (apos, npos) =-      let z = NE.tail statePos-      in (spanStart h :| z, spanEnd h :| z)-    r | null stateInput =-        ( st-        , Left ParseError-          { errorPos        = statePos-          , errorUnexpected = E.singleton EndOfInput-          , errorExpected   = E.singleton (Tokens $ nes span)-          , errorCustom     = E.empty } )-      | spanBody h == spanBody span =-          ( st { statePos = npos-               , stateInput = tail stateInput }-          , Right span )-      | otherwise =-          ( st { statePos = apos }-          , Left ParseError-            { errorPos        = apos-            , errorUnexpected = E.singleton (Tokens $ nes h)-            , errorExpected   = E.singleton (Tokens $ nes span)-            , errorCustom     = E.empty } )--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)--prop_cst_tokens :: State [Span] -> [Span] -> Property-prop_cst_tokens st' ts =-  forAll (incCoincidence st' ts) $ \st@State {..} ->-  let-    p = tokens compareTokens ts :: CustomParser [Span]-    compareTokens x y = spanBody x == spanBody y-    updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth-    ts' = NE.fromList ts-    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 )-    r | null ts = (st, Right [])-      | null stateInput =-        ( st-        , Left ParseError-          { errorPos        = statePos-          , errorUnexpected = E.singleton EndOfInput-          , errorExpected   = E.singleton (Tokens ts')-          , errorCustom     = E.empty } )-      | il == tl =-        ( st { statePos   = npos-             , stateInput = drop (length ts) stateInput }-        , Right consumed )-      | otherwise =-        ( st { statePos = apos }-        , Left ParseError-          { errorPos        = apos-          , errorUnexpected = E.singleton-            (Tokens . NE.fromList $ take (il + 1) stateInput)-          , errorExpected   = E.singleton (Tokens ts')-          , errorCustom     = E.empty } )-  in runParser' p st === r--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 }---- Functor instance--prop_functor :: Integer -> Integer -> Property-prop_functor n m =-  ((+ m) <$> return n) /=\ n + m .&&. ((* n) <$> return m) /=\ n * m---- Applicative instance--prop_applicative_0 :: Integer -> Integer -> Property-prop_applicative_0 n m = ((+) <$> pure n <*> pure m) /=\ n + m--prop_applicative_1 :: Char -> Char -> Property-prop_applicative_1 a b = a /= b ==> checkParser p r s-  where-    p = pure toUpper <*> (char a >> char a)-    r = posErr 1 s [utok b, etok a]-    s = [a,b]--prop_applicative_2 :: Integer -> Integer -> Property-prop_applicative_2 n m = (pure n *> pure m) /=\ m--prop_applicative_3 :: Integer -> Integer -> Property-prop_applicative_3 n m = (pure n <* pure m) /=\ n---- Alternative instance--prop_alternative_0 :: Integer -> Property-prop_alternative_0 n = (empty <|> return n) /=\ n--prop_alternative_1 :: String -> String -> Property-prop_alternative_1 s0 s1-  | s0 == s1 = checkParser p (Right s0) s1-  | null s0  = checkParser p (posErr 0 s1 [utok (head s1), eeof]) s1-  | s0 `isPrefixOf` s1 =-      checkParser p (posErr s0l s1 [utok (s1 !! s0l), eeof]) s1-  | otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1-    where p   = string s0 <|> string s1-          s0l = length s0--prop_alternative_2 :: Char -> Char -> Char -> Bool -> Property-prop_alternative_2 a b c l = checkParser p r s-  where p = char a <|> (char b >> char a)-        r | l         = Right a-          | a == b    = posErr 1 s [utok c, eeof]-          | a == c    = Right a-          | otherwise = posErr 1 s [utok c, etok a]-        s = if l then [a] else [b,c]--prop_alternative_3 :: Property-prop_alternative_3 = checkParser p r s-  where p  = asum [empty, string ">>>", empty, return "foo"] <?> "bar"-        p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"-        bsum = foldl (<|>) empty-        r = simpleParse p' s-        s = ">>"--prop_alternative_4 :: NonNegative Int -> NonNegative Int-                   -> NonNegative Int -> Property-prop_alternative_4 a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (++) <$> many (char 'a') <*> many (char 'b')-        r | null s = Right s-          | c > 0  = posErr (a + b) s $ [utok 'c', etok 'b', eeof]-                     ++ [etok 'a' | b == 0]-          | otherwise = Right s-        s = abcRow a b c--prop_alternative_5 :: NonNegative Int -> NonNegative Int-                   -> NonNegative Int -> Property-prop_alternative_5 a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (++) <$> some (char 'a') <*> some (char 'b')-        r | null s = posErr 0 s [ueof, etok 'a']-          | a == 0 = posErr 0 s [utok (head s), etok 'a']-          | b == 0 = posErr a s $ [etok 'a', etok 'b'] ++-                     if c > 0 then [utok 'c'] else [ueof]-          | c > 0 = posErr (a + b) s [utok 'c', etok 'b', eeof]-          | otherwise = Right s-        s = abcRow a b c--prop_alternative_6 :: Bool -> Bool -> Bool -> Property-prop_alternative_6 a b c = checkParser p r s-  where p = f <$> optional (char 'a') <*> optional (char 'b')-        f x y = maybe "" (:[]) x ++ maybe "" (:[]) y-        r | c = posErr ab s $ [utok 'c', eeof] ++-                [etok 'a' | not a && not b] ++ [etok 'b' | not b]-          | otherwise = Right s-        s = abcRow a b c-        ab = fromEnum a + fromEnum b---- Monad instance--prop_monad_0 :: Integer -> Property-prop_monad_0 n = checkParser (return n) (Right n) ""--prop_monad_1 :: Char -> Char -> Maybe Char -> Property-prop_monad_1 a b c = checkParser p r s-  where p = char a >> char b-        r = simpleParse (char a *> char b) s-        s = a : b : maybeToList c--prop_monad_2 :: Char -> Char -> Maybe Char -> Property-prop_monad_2 a b c = checkParser p r s-  where p = char a >>= \x -> char b >> return x-        r = simpleParse (char a <* char b) s-        s = a : b : maybeToList c--prop_monad_3 :: String -> Property-prop_monad_3 msg = checkParser p r s-  where p = fail msg :: Parser ()-        r = posErr 0 s [cstm (DecFail msg)]-        s = ""--prop_monad_left_id :: Integer -> Integer -> Property-prop_monad_left_id a b = (return a >>= f) !=! f a-  where f x = return $ x + b--prop_monad_right_id :: Integer -> Property-prop_monad_right_id a = (m >>= return) !=! m-  where m = return a--prop_monad_assoc :: Integer -> Integer -> Integer -> Property-prop_monad_assoc a b c = ((m >>= f) >>= g) !=! (m >>= (\x -> f x >>= g))-  where m = return a-        f x = return $ x + b-        g x = return $ x + c---- MonadIO instance--prop_monad_io :: Integer -> Property-prop_monad_io n = ioProperty (liftM (=== Right n) (runParserT p "" ""))-  where p = liftIO (return n) :: ParsecT Dec String IO Integer---- MonadReader instance--prop_monad_reader_ask :: Integer -> Property-prop_monad_reader_ask a = runReader (runParserT p "" "") a === Right a-  where p = ask :: ParsecT Dec String (Reader Integer) Integer--prop_monad_reader_local :: Integer -> Integer -> Property-prop_monad_reader_local a b =-  runReader (runParserT p "" "") a === Right (a + b)-  where p = local (+ b) ask :: ParsecT Dec String (Reader Integer) Integer---- MonadState instance--prop_monad_state_get :: Integer -> Property-prop_monad_state_get a = L.evalState (runParserT p "" "") a === Right a-  where p = L.get :: ParsecT Dec String (L.State Integer) Integer--prop_monad_state_put :: Integer -> Integer -> Property-prop_monad_state_put a b = L.execState (runParserT p "" "") a === b-  where p = L.put b :: ParsecT Dec String (L.State Integer) ()---- MonadCont instance--prop_monad_cont :: Integer -> Integer -> Property-prop_monad_cont a b = runCont (runParserT p "" "") id === Right (max a b)-  where p :: ParsecT Dec String-             (Cont (Either (ParseError Char Dec) Integer)) Integer-        p = do x <- callCC $ \e -> when (a > b) (e a) >> return b-               return x---- MonadError instance--prop_monad_error_throw :: Integer -> Integer -> Property-prop_monad_error_throw a b = runExcept (runParserT p "" "") === Left a-  where p :: ParsecT Dec String (Except Integer) Integer-        p = throwError a >> return b--prop_monad_error_catch :: Integer -> Integer -> Property-prop_monad_error_catch a b =-  runExcept (runParserT p "" "") === Right (Right $ a + b)-  where p :: ParsecT Dec String (Except Integer) Integer-        p = (throwError a >> return b) `catchError` handler-        handler e = return (e + b)---- Primitive combinators--prop_unexpected :: ErrorItem Char -> Property-prop_unexpected item = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = unexpected item-        r = posErr 0 s [Unexpected item]-        s = ""--prop_failure-  :: Set (ErrorItem Char)-  -> Set (ErrorItem Char)-  -> Set Dec-  -> Property-prop_failure us ps xs = checkParser' p r s-  where p :: (MonadParsec Dec s m, Token s ~ Char) => m String-        p = failure us ps xs-        r = Left ParseError-          { errorPos        = nes (initialPos "")-          , errorUnexpected = us-          , errorExpected   = ps-          , errorCustom     = xs }-        s = ""--prop_label :: NonNegative Int -> NonNegative Int-           -> NonNegative Int -> String -> Property-prop_label a' b' c' l = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = (++) <$> many (char 'a') <*> (many (char 'b') <?> l)-        r | null s = Right s-          | c > 0 = posErr (a + b) s $ [utok 'c', eeof]-            ++ [etok 'a' | b == 0]-            ++ (if null l-                  then []-                  else [if b == 0-                         then elabel l-                         else elabel ("rest of " ++ l)])-          | otherwise = Right s-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_hidden_0 :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_hidden_0 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = (++) <$> many (char 'a') <*> hidden (many (char 'b'))-        r | null s = Right s-          | c > 0  = posErr (a + b) s $ [utok 'c', eeof]-                     ++ [etok 'a' | b == 0]-          | otherwise = Right s-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_hidden_1 :: NonEmptyList Char -> String -> Property-prop_hidden_1 c' s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m (Maybe String)-        p = optional (hidden $ string c)-        r | null s           = Right Nothing-          | c == s           = Right (Just s)-          | c `isPrefixOf` s = posErr cn s [utok (s !! cn), eeof]-          | otherwise        = posErr 0 s [utok (head s), eeof]-        c = getNonEmpty c'-        cn = length c--prop_try :: Char -> Char -> Char -> Property-prop_try pre ch1 ch2 = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = try (sequence [char pre, char ch1])-          <|> sequence [char pre, char ch2]-        r = posErr 1 s [ueof, etok ch1, etok ch2]-        s = [pre]--prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property-prop_lookAhead_0 a b c = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = do-          l <- lookAhead (oneOf "ab" <?> "label")-          guard (l == h)-          char 'a'-        h = head s-        r | null s = posErr 0 s [ueof, elabel "label"]-          | s == "a" = Right 'a'-          | h == 'b' = posErr 0 s [utok 'b', etok 'a']-          | h == 'c' = posErr 0 s [utok 'c', elabel "label"]-          | otherwise  = posErr 1 s [utok (s !! 1), eeof]-        s = abcRow a b c--prop_lookAhead_1 :: String -> Property-prop_lookAhead_1 s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = lookAhead (some letterChar) >> fail emsg-        h = head s-        r | null s     = posErr 0 s [ueof, elabel "letter"]-          | isLetter h = posErr 0 s [cstm (DecFail emsg)]-          | otherwise  = posErr 0 s [utok h, elabel "letter"]-        emsg = "ops!"--prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property-prop_lookAhead_2 a b c = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = lookAhead (some (char 'a')) >> char 'b'-        r | null s    = posErr 0 s [ueof, etok 'a']-          | a         = posErr 0 s [utok 'a', etok 'b']-          | otherwise = posErr 0 s [utok (head s), etok 'a']-        s = abcRow a b c--case_lookAhead_3 :: Assertion-case_lookAhead_3 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = lookAhead (char 'a' *> fail emsg)-        r = posErr 1 s [cstm (DecFail emsg)]-        emsg = "ops!"-        s = "abc"--prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_0 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c')-        r | b > 0     = posErr a s [utok 'b', etok 'a']-          | otherwise = Right (replicate a 'a')-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_1 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a')-          <* (notFollowedBy . notFollowedBy) (char 'c')-          <* many (char 'c')-        r | b == 0 && c > 0 = Right (replicate a 'a')-          | b > 0           = posErr a s [utok 'b', etok 'a']-          | otherwise       = posErr a s [ueof, etok 'a']-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_2 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a') <* notFollowedBy eof <* many anyChar-        r | b > 0 || c > 0 = Right (replicate a 'a')-          | otherwise      = posErr a s [ueof, etok 'a']-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--case_notFollowedBy_3a :: Assertion-case_notFollowedBy_3a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy (char 'a' *> char 'c')-        r = Right ()-        s = "ab"--case_notFollowedBy_3b :: Assertion-case_notFollowedBy_3b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy (char 'a' *> char 'd') <* char 'c'-        r = posErr 0 s [utok 'a', etok 'c']-        s = "ab"--case_notFollowedBy_4a :: Assertion-case_notFollowedBy_4a = checkCase' p r s-  where p :: MonadParsec e s m => m ()-        p = notFollowedBy mzero-        r = Right ()-        s = "ab"--case_notFollowedBy_4b :: Assertion-case_notFollowedBy_4b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy mzero <* char 'c'-        r = posErr 0 s [utok 'a', etok 'c']-        s = "ab"--prop_withRecovery_0-  :: NonNegative Int-  -> NonNegative Int-  -> NonNegative Int-  -> Property-prop_withRecovery_0 a' b' c' = checkParser' p r s-  where-    p :: (MonadParsec Dec s m, Token s ~ Char)-      => 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-    r | a == 0 && b == 0 && c == 0 = posErr 0 s [ueof, etok 'a']-      | a == 0 && b == 0 && c >  3 = posErr 0 s [utok 'c', etok 'a']-      | a == 0 && b == 0           = posErr 0 s [utok 'c', etok 'a']-      | a == 0 && b >  3           = posErr 3 s [utok 'b', etok 'a', etok 'c']-      | a == 0 &&           c == 0 = posErr b s [ueof, etok 'a', etok 'c']-      | a == 0 &&           c >  3 = posErr (b + 3) s [utok 'c', eeof]-      | a == 0                     = Right (posErr 0 s [utok 'b', etok 'a'])-      | a >  3                     = posErr 3 s [utok 'a', etok 'c']-      |           b == 0 && c == 0 = posErr a s $ [ueof, etok 'c'] ++ ma-      |           b == 0 && c >  3 = posErr (a + 3) s [utok 'c', eeof]-      |           b == 0           = Right (Right s)-      | otherwise                  = posErr a s $ [utok 'b', etok 'c'] ++ ma-    ma = [etok 'a' | a < 3]-    s = abcRow a b c-    [a,b,c] = getNonNegative <$> [a',b',c']--case_withRecovery_1 :: Assertion-case_withRecovery_1 = checkCase' p r s-  where p :: MonadParsec e s m => m String-        p = withRecovery (const $ return "bar") (return "foo")-        r = Right "foo"-        s = "abc"--case_withRecovery_2 :: Assertion-case_withRecovery_2 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (\_ -> char 'a' *> mzero) (string "cba")-        r = posErr 0 s [utoks "a", etoks "cba"]-        s = "abc"--case_withRecovery_3a :: Assertion-case_withRecovery_3a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (string "cba")-        r = Right "abd"-        s = "abc"--case_withRecovery_3b :: Assertion-case_withRecovery_3b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (string "cba") <* char 'd'-        r = posErr 0 s [utok 'a', etoks "cba", etok 'd']-        s = "abc"--case_withRecovery_4a :: Assertion-case_withRecovery_4a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ string "bc") (char 'a' *> mzero)-        r = Right "bc"-        s = "abc"--case_withRecovery_4b :: Assertion-case_withRecovery_4b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ string "bc")-          (char 'a' *> char 'd' *> pure "foo") <* char 'f'-        r = posErr 3 s [ueof, etok 'f']-        s = "abc"--case_withRecovery_5 :: Assertion-case_withRecovery_5 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail emsg)-        r = posErr 1 s [cstm (DecFail emsg)]-        emsg = "ops!"-        s = "abc"--case_withRecovery_6a :: Assertion-case_withRecovery_6a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (char 'a' *> mzero)-        r = Right "abd"-        s = "abc"--case_withRecovery_6b :: Assertion-case_withRecovery_6b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f'-        r = posErr 1 s [utok 'b', etok 'd', etok 'f']-        s = "abc"--case_withRecovery_7 :: Assertion-case_withRecovery_7 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = withRecovery (const mzero) (char 'a' *> char 'd')-        r = posErr 1 s [utok 'b', etok 'd']-        s = "abc"--case_eof :: Assertion-case_eof = checkCase' eof (Right ()) ""--prop_token :: Maybe Char -> String -> Property-prop_token mtok s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = token testChar mtok-        testChar x = if isLetter x-          then Right x-          else Left (E.singleton (Tokens $ nes x), E.empty, E.empty)-        h = head s-        r | null s = posErr 0 s $ ueof : maybeToList (etok <$> mtok)-          | isLetter h && length s == 1 = Right (head s)-          | isLetter h && length s > 1 = posErr 1 s [utok (s !! 1), eeof]-          | otherwise = posErr 0 s [utok h]--prop_tokens_0 :: String -> String -> Property-prop_tokens_0 a = checkString (tokens (==) a) a (==)--prop_tokens_1 :: String -> String -> String -> Property-prop_tokens_1 pre post post' =-  not (post `isPrefixOf` post') ==>-  (leftover === "" .||. leftover === s)-  where p :: Parser String-        p = tokens (==) (pre ++ post)-        s = pre ++ post'-        st = stateFromInput s-        leftover = stateInput . fst $ runParser' p st---- Parser state combinators--prop_state_pos :: State String -> SourcePos -> Property-prop_state_pos st pos = runParser' p st === r-  where p = (setPosition pos >> getPosition) :: Parser SourcePos-        r = (f st pos, Right pos)-        f (State s (_:|xs) w) y = State s (y:|xs) w--prop_state_pushPosition :: State String -> SourcePos -> Property-prop_state_pushPosition st pos = fst (runParser' p st) === r-  where p = pushPosition pos :: Parser ()-        r = st { statePos = NE.cons pos (statePos st) }--prop_state_popPosition :: State String -> Property-prop_state_popPosition st = fst (runParser' p st) === r-  where p = popPosition :: Parser ()-        r = st { statePos = fromMaybe pos (snd (NE.uncons pos)) }-        pos = statePos st--prop_state_input :: String -> Property-prop_state_input s = p /=\ s-  where p = do-          st0    <- getInput-          guard (null st0)-          setInput s-          result <- string s-          st1    <- getInput-          guard (null st1)-          return result--prop_state_tab :: Pos -> Property-prop_state_tab w = p /=\ w-  where p = setTabWidth w >> getTabWidth--prop_state :: State String -> State String -> Property-prop_state s1 s2 = checkParser' p r s-  where p :: MonadParsec Dec String m => m (State String)-        p = do-          st <- getParserState-          guard (st == State s (nes $ initialPos "") defaultTabWidth)-          setParserState s1-          updateParserState (f s2)-          liftM2 const getParserState (setInput "")-        f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w-        r = Right (f s2 s1)-        s = ""---- Running a parser--prop_parseMaybe :: String -> String -> Property-prop_parseMaybe s s' = parseMaybe p s === r-  where p = string s' :: Parser String-        r = if s == s' then Just s else Nothing--prop_runParser' :: State String -> String -> Property-prop_runParser' st s = runParser' p st === r-  where p = string s-        r = emulateStrParsing st s--prop_runParserT' :: State String -> String -> Property-prop_runParserT' st s = runIdentity (runParserT' p st) === r-  where p = string s-        r = emulateStrParsing st s--emulateStrParsing-  :: State String-  -> String-  -> (State String, Either (ParseError Char Dec) String)-emulateStrParsing st@(State i (pos:|z) t) s =-  if l == length s-    then (State (drop l i) (updatePosString t pos s :| z) t, Right s)-    else (st, posErr' (pos:|z) (etoks s : [utoks (take (l + 1) i)]))-  where l = length (takeWhile id $ zipWith (==) s i)---- Additional tests to check returned state on failure--prop_stOnFail_0 :: Positive Int -> Positive Int -> Property-prop_stOnFail_0 na' nb' = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State "" (errorPos x) defaultTabWidth-        na = getPositive na'-        nb = getPositive nb'-        p = try (many (char 'a') <* many (char 'b') <* char 'c')-          <|> (many (char 'a') <* char 'c')-        r = posErr (na + nb) s [etok 'b', etok 'c', ueof]-        s = replicate na 'a' ++ replicate nb 'b'--prop_stOnFail_1 :: Positive Int -> Pos -> Property-prop_stOnFail_1 na' t = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State "" (errorPos x) t-        na = getPositive na'-        p = many (char 'a') <* setTabWidth t <* fail emsg-        r = posErr na s [cstm (DecFail emsg)]-        s = replicate na 'a'-        emsg = "failing now!"--prop_stOnFail_2 :: String -> Char -> Property-prop_stOnFail_2 s' ch = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State [ch] (errorPos x) defaultTabWidth-        r = posErr (length s') s [utok ch, eeof]-        p = string s' <* eof-        s = s' ++ [ch]--prop_stOnFail_3 :: String -> Property-prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State s (errorPos x) defaultTabWidth-        r = posErr 0 s [if null s then ueof else utok (head s)]-        p = notFollowedBy (string s)--stateFromInput :: s -> State s-stateFromInput s = State s (nes $ initialPos "") defaultTabWidth---- ReaderT instance of MonadParsec--prop_ReaderT_try :: Char -> Char -> Char -> Property-prop_ReaderT_try pre ch1 ch2 = checkParser (runReaderT p (s1, s2)) r s-  where s1 = pre : [ch1]-        s2 = pre : [ch2]-        getS1 = asks fst-        getS2 = asks snd-        p = try (g =<< getS1) <|> (g =<< getS2)-        g = sequence . fmap char-        r = posErr 1 s [ueof, etok ch1, etok ch2]-        s = [pre]--prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int-                           -> NonNegative Int -> Property-prop_ReaderT_notFollowedBy a' b' c' = checkParser (runReaderT p 'a') r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = many (char =<< ask) <* notFollowedBy eof <* many anyChar-        r | b > 0 || c > 0 = Right (replicate a 'a')-          | otherwise      = posErr a s [ueof, etok 'a']-        s = abcRow a b c---- StateT instance of MonadParsec--prop_StateT_alternative :: Integer -> Property-prop_StateT_alternative n =-  checkParser (L.evalStateT p 0) (Right n) "" .&&.-  checkParser (S.evalStateT p' 0) (Right n) ""-  where p  = L.put n >> ((L.modify (* 2) >>-                          void (string "xxx")) <|> return ()) >> L.get-        p' = S.put n >> ((S.modify (* 2) >>-                          void (string "xxx")) <|> return ()) >> S.get--prop_StateT_lookAhead :: Integer -> Property-prop_StateT_lookAhead n =-  checkParser (L.evalStateT p 0) (Right n) "" .&&.-  checkParser (S.evalStateT p' 0) (Right n) ""-  where p  = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get-        p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get--prop_StateT_notFollowedBy :: Integer -> Property-prop_StateT_notFollowedBy n = checkParser (L.runStateT p 0) r "abx" .&&.-                              checkParser (S.runStateT p' 0) r "abx"-  where p = do-          L.put n-          let notEof = notFollowedBy (L.modify (* 2) >> eof)-          some (try (anyChar <* notEof)) <* char 'x'-        p' = do-          S.put n-          let notEof = notFollowedBy (S.modify (* 2) >> eof)-          some (try (anyChar <* notEof)) <* char 'x'-        r = Right ("ab", n)---- WriterT instance of MonadParsec--prop_WriterT :: String -> String -> Property-prop_WriterT pre post =-  checkParser (L.runWriterT p) r "abx" .&&.-  checkParser (S.runWriterT p') r "abx"-  where logged_letter  = letterChar >>= \x -> L.tell [x] >> return x-        logged_letter' = letterChar >>= \x -> L.tell [x] >> return x-        logged_eof     = eof >> L.tell "EOF"-        logged_eof'    = eof >> L.tell "EOF"-        p = do-          L.tell pre-          cs <- L.censor (fmap toUpper) $-                  some (try (logged_letter <* notFollowedBy logged_eof))-          L.tell post-          void logged_letter-          return cs-        p' = do-          L.tell pre-          cs <- L.censor (fmap toUpper) $-                  some (try (logged_letter' <* notFollowedBy logged_eof'))-          L.tell post-          void logged_letter'-          return cs-        r = Right ("ab", pre ++ "AB" ++ post ++ "x")--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}
− tests/Util.hs 
@@ -1,367 +0,0 @@------ QuickCheck tests for Megaparsec, utility functions for parser testing.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# OPTIONS -fno-warn-orphans #-}--module Util-  ( checkParser-  , checkParser'-  , checkCase-  , checkCase'-  , simpleParse-  , checkChar-  , checkString-  , updatePosString-  , (/=\)-  , (!=!)-  , abcRow-  , EC (..)-  , posErr-  , posErr'-  , utok-  , utoks-  , ulabel-  , ueof-  , etok-  , etoks-  , elabel-  , eeof-  , cstm )-where--import Control.Monad.Reader-import Control.Monad.Trans.Identity-import Data.Foldable (foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (mapMaybe, maybeToList)-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.List.NonEmpty          as NE-import qualified Data.Set                    as E--import Test.QuickCheck-import Test.HUnit (Assertion, (@?=))--import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), (<*))-#endif---- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse--- entire @s@. Result of the parsing is compared with expected result @r@,--- it should match, otherwise the property doesn't hold and the test fails.--checkParser :: (Eq a, Show a)-  => Parser a          -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Property          -- ^ Resulting property-checkParser p r s = simpleParse p s === r---- | A variant of 'checkParser' that runs given parser code with all--- standard instances of 'MonadParsec'. Useful when testing primitive--- combinators.--checkParser' :: (Eq a, Show a)-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Property          -- ^ Resulting property-checkParser' p r s = conjoin-  [ checkParser p                   r s-  , checkParser (runIdentityT p)    r s-  , checkParser (runReaderT   p ()) r s-  , checkParser (L.evalStateT p ()) r s-  , checkParser (S.evalStateT p ()) r s-  , checkParser (evalWriterTL p)    r s-  , checkParser (evalWriterTS p)    r s ]---- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.--checkCase :: (Eq a, Show a)-  => Parser a          -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Assertion         -- ^ Resulting assertion-checkCase p r s = simpleParse p s @?= r---- | Similar to 'checkParser'', but produces HUnit's 'Assertion's instead.--checkCase' :: (Eq a, Show a)-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Assertion         -- ^ Resulting assertion-checkCase' p r s = do-  parse p                   "" s @?= r-  parse (runIdentityT p)    "" s @?= r-  parse (runReaderT   p ()) "" s @?= r-  parse (L.evalStateT p ()) "" s @?= r-  parse (S.evalStateT p ()) "" s @?= r-  parse (evalWriterTL p)    "" s @?= r-  parse (evalWriterTS p)    "" s @?= r--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---- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding--- result of type @Either ParseError a@, where @a@ is type of parsed--- value. This parser tries to parser end of file too and name of input file--- is always empty string.--simpleParse :: Parser a -> String -> Either (ParseError Char Dec) a-simpleParse p = parse (p <* eof) ""---- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if--- the parser correctly parses single character that satisfies @test@. The--- character may be labelled, in this case @label@ is used to check quality--- of error messages.--checkChar-  :: Parser Char       -- ^ Parser to run-  -> (Char -> Bool)    -- ^ Predicate to test parsed char-  -> Maybe (ErrorItem Char) -- ^ Representation to use in error messages-  -> String            -- ^ Input stream-  -> Property          -- ^ Resulting property-checkChar p f rep' s = checkParser p r s-  where h = head s-        rep = Expected <$> maybeToList rep'-        r | null s = posErr 0 s (ueof : rep)-          | length s == 1 && f h = Right h-          | not (f h) = posErr 0 s (utok h : rep)-          | otherwise = posErr 1 s [utok (s !! 1), eeof]---- | @checkString p a test label s@ runs parser @p@ on input @s@ and checks if--- the result is equal to @a@ and also quality of error messages. @test@ is--- used to compare tokens. @label@ is used as expected representation of--- parser's result in error messages.--checkString-  :: Parser String     -- ^ Parser to run-  -> String            -- ^ Expected result-  -> (Char -> Char -> Bool) -- ^ Function used to compare tokens-  -> String            -- ^ Input stream-  -> Property-checkString p a' test s' = checkParser p (w a' 0 s') s'-  where w [] _ []    = Right s'-        w [] i (s:_) = posErr i s' [utok s, eeof]-        w _  0 []    = posErr 0 s' [ueof, etoks a']-        w _  i []    = posErr 0 s' [utoks (take i s'), etoks a']-        w (a:as) i (s:ss)-          | test a s  = w as i' ss-          | otherwise = posErr 0 s' [utoks (take i' s'), etoks a']-            where i'  = succ i---- | 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)--infix 4 /=\   -- preserve whitespace on automatic trim---- | @p /=\\ x@ runs parser @p@ on empty input and compares its result--- (which should be successful) with @x@. Succeeds when the result is equal--- to @x@, prints counterexample on failure.--(/=\) :: (Eq a, Show a) => Parser a -> a -> Property-p /=\ x = simpleParse p "" === Right x--infix 4 !=!---- | @n !=! m@ represents property that holds when results of running @n@--- and @m@ parsers are identical. This is useful when checking monad laws--- for example.--(!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property-n !=! m = simpleParse n "" === simpleParse m ""---- | @abcRow a b c@ generates string consisting of character “a” repeated--- @a@ times, character “b” repeated @b@ times, and finally character “c”--- repeated @c@ times.--abcRow :: Enum a => a -> a -> a -> String-abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'-  where f x = replicate (fromEnum x)---- | A component of parse error, useful for fast and dirty construction of--- parse errors with 'posErr' and other helpers.--data EC-  = Unexpected (ErrorItem Char)-  | Expected   (ErrorItem Char)-  | Custom     Dec--instance Arbitrary a => Arbitrary (NonEmpty a) where-  arbitrary = NE.fromList . getNonEmpty <$> arbitrary--instance Arbitrary t => Arbitrary (ErrorItem t) where-  arbitrary = oneof-    [ Tokens <$> arbitrary-    , Label  <$> arbitrary-    , return EndOfInput ]--instance Arbitrary Pos where-  arbitrary = unsafePos . getPositive <$> arbitrary--instance Arbitrary SourcePos where-  arbitrary = SourcePos-    <$> shortString-    <*> (unsafePos <$> choose (1, 1000))-    <*> (unsafePos <$> choose (1,  100))--instance Arbitrary Dec where-  arbitrary = oneof-    [ DecFail        <$> shortString-    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]--instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where-  arbitrary = ParseError-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary--shortString :: Gen String-shortString = sized $ \n -> do-  k <- choose (0, n `div` 2)-  vectorOf k arbitrary---- | @posErr pos s ms@ is an easy way to model result of parser that fails.--- @pos@ is how many tokens (characters) has been consumed before failure.--- @s@ is input of the parser. @ms@ is a list, collection of 'Message's. See--- 'utok', 'utoks', 'ulabel', 'ueof', 'etok', 'etoks', 'elabel', and 'eeof'--- for easy ways to create error messages.--posErr-  :: Int               -- ^ How many tokens to drop from beginning of steam-  -> String            -- ^ The input stream (just a 'String' here)-  -> [EC]              -- ^ Collection of error components-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'-posErr i s = posErr' (pos :| [])-  where pos = updatePosString defaultTabWidth (initialPos "") (take i s)---- | The same as 'posErr', but 'SourcePos' should be provided directly.--posErr'-  :: NonEmpty SourcePos -- ^ Position of the error-  -> [EC]              -- ^ Collection of error components-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'-posErr' pos ecs = Left ParseError-  { errorPos        = pos-  , errorUnexpected = E.fromList (mapMaybe getUnexpected ecs)-  , errorExpected   = E.fromList (mapMaybe getExpected   ecs)-  , errorCustom     = E.fromList (mapMaybe getCustom     ecs) }-  where-    getUnexpected (Unexpected x) = Just x-    getUnexpected _              = Nothing-    getExpected   (Expected   x) = Just x-    getExpected   _              = Nothing-    getCustom     (Custom     x) = Just x-    getCustom     _              = Nothing---- | Construct “unexpected token” error component.--utok :: Char -> EC-utok = Unexpected . Tokens . nes---- | Construct “unexpected steam” error component. This function respects--- some conventions described in 'canonicalizeStream'.--utoks :: String -> EC-utoks = Unexpected . canonicalizeStream---- | Construct “unexpected label” error component. Do not use with empty--- strings.--ulabel :: String -> EC-ulabel = Unexpected . Label . NE.fromList---- | Construct “unexpected end of input” error component.--ueof :: EC-ueof = Unexpected EndOfInput---- | Construct “expecting token” error component.--etok :: Char -> EC-etok = Expected . Tokens . nes---- | Construct “expecting stream” error component. This function respects--- some conventions described in 'canonicalizeStream'.--etoks :: String -> EC-etoks = Expected . canonicalizeStream---- | Construct “expecting label” error component. Do not use with empty--- strings.--elabel :: String -> EC-elabel = Expected . Label . NE.fromList---- | Construct “expecting end of input” component.--eeof :: EC-eeof = Expected EndOfInput---- | Construct error component consisting of custom data.--cstm :: Dec -> EC-cstm = Custom---- | Construct appropriate 'MessageItem' representation for given token--- stream. Empty string produces 'EndOfInput', single token — a 'Token', and--- in other cases the 'TokenStream' constructor is used.--canonicalizeStream :: String -> ErrorItem Char-canonicalizeStream stream =-  case NE.nonEmpty stream of-    Nothing      -> EndOfInput-    Just xs      -> Tokens xs---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}