diff --git a/AUTHORS.md b/AUTHORS.md deleted file mode 100644 --- a/AUTHORS.md +++ /dev/null @@ -1,53 +0,0 @@ -# Authors - -The following people have contributed to Megaparsec/Parsec library. Due to -the fact that original Parsec project has not been keeping this sort of -file, many contributors are missing from this list, if you've contributed to -Parsec project in the past, please open an issue or a pull request, so we -can add you to this list. - -Names below are sorted alphabetically. - -## Author of original Parsec library - -* Daan Leijen - -## Maintainer - -* Mark Karpov - -## Retired maintainers - -* Antoine Latter -* Derek Elkins - -## Contributors - -* Albert Netymk -* Antoine Latter -* Artyom (@neongreen) -* Auke Booij -* Ben Pence -* Benjamin Kästner -* Björn Buckwalter -* Bryan O'Sullivan -* Cies Breijs -* Daniel Díaz -* Daniel Gorín -* Dennis Gosnell -* Derek Elkins -* Emil Sköldberg -* Herbert Valerio Riedel -* Joel Williamson -* Mark Karpov -* Paolo Martini -* redneb -* Reto Kramer -* Rogan Creswick -* Roman Cheplyaka -* Ryan Scott -* Simon Vandel -* Slava Shklyaev -* Tal Walter -* Tomáš Janoušek -* Vladislav Zavialov diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,570 @@ +*Megaparsec follows [SemVer](https://semver.org/).* + +## Megaparsec 9.8.1 + +* Fixed the regression introduced by the fix for the [issue + 572](https://github.com/mrkkrp/megaparsec/issues/572) which caused the + position marker `^` to be missing in certain cases. +* This release officially supports GHC 9.6. This is the oldest GHC version + we support at this time. + +## Megaparsec 9.8.0 + +* Fixed the associativity of the `(<|>)` operator. [Issue + 412](https://github.com/mrkkrp/megaparsec/issues/412). +* Fixed the loss of precision in `decimal`, `binary`, `octal`, and + `hexadecimal` functions in `Text.Megaparsec.Byte.Lexer` and + `Text.Megaparsec.Char.Lexer` when they are used to parse floating point + numbers. [Issue 479](https://github.com/mrkkrp/megaparsec/issues/479). +* Fixed handling of zero-width characters in error messages. To that end, + added `isZeroWidthChar` function in `Text.Megaparsec.Unicode`. [Issue + 572](https://github.com/mrkkrp/megaparsec/issues/572). + +## Megaparsec 9.7.1 + +* Typo fixes and compatibility with `QuickCheck >= 2.17` for + `megaparsec-tests`. + +## Megaparsec 9.7.0 + +* Implemented correct handling of wide Unicode characters in error messages. + To that end, a new module `Text.Megaparsec.Unicode` was introduced. [Issue + 370](https://github.com/mrkkrp/megaparsec/issues/370). +* Inlined `Applicative` operators `(<*)` and `(*>)`. [PR + 566](https://github.com/mrkkrp/megaparsec/pull/566). +* `many` and `some` of the `Alternative` instance of `ParsecT` are now more + efficient, since they use the monadic implementations under the hood. + [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567). +* Added `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR + 573](https://github.com/mrkkrp/megaparsec/pull/573). + +## Megaparsec 9.6.1 + +* Exposed `Text.Megaparsec.State`, so that the new functions (`initialState` + and `initialPosState`) can be actually imported from it. [PR + 549](https://github.com/mrkkrp/megaparsec/pull/549). + +## Megaparsec 9.6.0 + +* Added the functions `initialState` and `initialPosState` to + `Text.Megaparsec.State`. [Issue + 449](https://github.com/mrkkrp/megaparsec/issues/449). + +## Megaparsec 9.5.0 + +* Dropped a number of redundant constraints here and there. [PR + 523](https://github.com/mrkkrp/megaparsec/pull/523). + +* Added a `MonadWriter` instance for `ParsecT`. [PR + 534](https://github.com/mrkkrp/megaparsec/pull/534). + +## Megaparsec 9.4.1 + +* Removed `Monad m` constraints in several places where they were introduced + in 9.4.0. [Issue 532](https://github.com/mrkkrp/megaparsec/issues/532). + +## Megaparsec 9.4.0 + +* `dbg` now prints hints among other debug information. [PR + 530](https://github.com/mrkkrp/megaparsec/pull/530). + +* Hints are no longer lost in certain methods of MTL instances for + `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528). + +* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be + used to construct “new primitives” with arbitrary behavior at the expense + of having to dive into Megaparsec's internals. [PR + 514](https://github.com/mrkkrp/megaparsec/pull/514). + +## Megaparsec 9.3.1 + +* Fixed a bug related to processing of tabs when error messages are + rendered. [Issue 524](https://github.com/mrkkrp/megaparsec/issues/524). + +## Megaparsec 9.3.0 + +* Now `label` can override more than one group of hints in the parser it + wraps. [Issue 482](https://github.com/mrkkrp/megaparsec/issues/482). + +* `takeP n` now returns the empty chunk of the input stream when `n` is + negative, similar to when `n == 0`. [Issue + 497](https://github.com/mrkkrp/megaparsec/issues/497). + +* Added the `MonadParsecDbg` type class in `Text.Megaparsec.Debug`. The type + class allows us to use `dbg` in MTL monad transformers. [Issue + 488](https://github.com/mrkkrp/megaparsec/issues/488). + +* Introduced the `ShareInput` and `NoShareInput` newtype wrappers in + `Text.Megaparsec.Stream` in order to allow the user to choose how the + input should be sliced and shared during the parsing. [Issue + 492](https://github.com/mrkkrp/megaparsec/issues/492). + +## Megaparsec 9.2.2 + +* Fixed a space leak in the implementations of the `reachOffset` and + `reachOffsetNoLine` methods of `TraversableStream`. [Issue + 486](https://github.com/mrkkrp/megaparsec/issues/486). + +## Megaparsec 9.2.1 + +* Builds with `mtl-2.3` and `transformers-0.6`. + +## Megaparsec 9.2.0 + +* Added parsers for binary representations (little/big endian) of numbers in + `Text.Megaparsec.Byte.Binary`. + +## Megaparsec 9.1.0 + +* Added `dbg'` in `Text.Megaparsec.Debug` for debugging parsers that have + unshowable return values. + +* Documentation improvements. + +## Megaparsec 9.0.1 + +* Added [Safe + Haskell](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html) + support. + +## Megaparsec 9.0.0 + +* Split the `Stream` type class. The methods `showTokens` and `tokensLength` + have been put into a separate type class `VisualStream`, while + `reachOffset` and `reachOffsetNoLine` are now in `TraversableStream`. This + should make defining `Stream` instances for custom streams easier. + +* Defined `Stream` instances for lists and `Seq`s. + +* Added the functions `hspace` and `hspace1` to the `Text.Megaparsec.Char` + and `Text.Megaparsec.Byte` modules. + +## Megaparsec 8.0.0 + +* The methods `failure` and `fancyFailure` of `MonadParsec` are now ordinary + functions and live in `Text.Megaparsec`. They are defined in terms of the + new `parseError` method of `MonadParsec`. This method allows us to signal + parse errors at a given offset without manipulating parser state manually. + +* Megaparsec now supports registration of “delayed” parse errors. On lower + level we added a new field called `stateParseErrors` to the `State` + record. The type also had to change from `State s` to `State s e`. This + field contains the list of registered `ParseErrors` that do not end + parsing immediately but still will cause failure in the end if the list is + not empty. Users are expected to register parse errors using the three + functions: `registerParseError`, `registerFailure`, and + `registerFancyFailure`. These functions are analogous to those without the + `register` prefix, except that they have “delayed” effect. + +* Added the `tokensLength` method to the `Stream` type class to improve + support for custom input streams. + +* Added the `setErrorOffset` function to set offset of `ParseError`s. + +* Changed type signatures of `reachOffset` and `reachOffsetNoLine` methods + of the `Stream` type class. Instead of three-tuple `reachOffset` now + returns two-tuple because `SourcePos` is already contained in the returned + `PosState` record. + +* Generalized `decimal`, `binary`, `octal`, and `hexadecimal` parsers in + lexer modules so that they `Num` instead of just `Integral`. + +* Dropped support for GHC 8.2.x and older. + +## Megaparsec 7.0.5 + +* Dropped support for GHC 7.10. + +* Adapted the code to `MonadFail` changes in `base-4.13`. + +* Separated the test suite into its own package. The reason is that we can + avoid circular dependency on `hspec-megaparsec` and thus avoid keeping + copies of its source files in our test suite, as we had to do before. + Another benefit is that we can export some auxiliary functions in + `megaparsec-tests` which can be used by other test suites, for example in + the `parser-combinators-tests` package. + + Version of `megaparsec-tests` will be kept in sync with versions of + `megaparsec` from now on. + +## Megaparsec 7.0.4 + +* Numerous documentation corrections. + +## Megaparsec 7.0.3 + +* Fixed the build with `mtl` older than `2.2.2`. + +## Megaparsec 7.0.2 + +* Fixed the property test for `char'` which was failing in the case when + there is a character with different upper and title cases. + +* More descriptive error messages when `elabel` or `ulabel` from + `Text.Megaparsec.Error.Builder` are used with empty strings. + +* Typo fixes in the docs. + +## Megaparsec 7.0.1 + +* Fixed a bug in `errorBundlePretty`. Previously the question sign `?` was + erroneously inserted before offending line in 2nd and later parse errors. + +## Megaparsec 7.0.0 + +### General + +* Dropped the `Text.Megaparsec.Perm` module. Use + `Control.Applicative.Permutations` from `parser-combinators` instead. + +* Dropped the `Text.Megaparsec.Expr` module. Use + `Control.Monad.Combinators.Expr` from `parser-combinators` instead. + +* The debugging function `dbg` has been moved from `Text.Megaparsec` to its + own module `Text.Megaparsec.Debug`. + +* Dropped support for GHC 7.8. + +### Combinators + +* Moved some general combinators from `Text.Megaparsec.Char` and + `Text.Megaparsec.Byte` to `Text.Megaparsec`, renaming some of them for + clarity. + + Practical consequences: + + * Now there is the `single` combinator that is a generalization of `char` + for arbitrary streams. `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` + still contain `char` as type-constrained versions of `single`. + + * Similarly, now there is the `chunk` combinator that is a generalization + of `string` for arbitrary streams. The `string` combinator is still + re-exported from `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` for + compatibility. + + * `satisfy` does not depend on type of token, and so it now lives in + `Text.Megaparsec`. + + * `anyChar` was renamed to `anySingle` and moved to `Text.Megaparsec`. + + * `notChar` was renamed to `anySingleBut` and moved to `Text.Megaparsec`. + + * `oneOf` and `noneOf` were moved to `Text.Megaparsec`. + +* Simplified the type of the `token` primitive. It now takes just a matching + function `Token s -> Maybe a` as the first argument and the collection of + expected items `Set (ErrorItem (Token s))` as the second argument. This + makes sense because the collection of expected items cannot depend on what + we see in the input stream. + +* The `label` primitive now doesn't prepend the phrase “the rest of” to the + label when its inner parser produces hints after consuming input. In that + case `label` has no effect. + +* Fixed the `Text.Megaparsec.Char.Lexer.charLiteral` so it can accept longer + escape sequences (max length is now 10). + +* Added the `binDigitChar` functions in `Text.Megaparsec.Byte` and + `Text.Megaparsec.Char`. + +* Added the `binary` functions in `Text.Megaparsec.Byte.Lexer` and + `Text.Megaparsec.Char.Lexer`. + +* Improved case-insensitive character matching in the cases when e.g. + `isLower` and `isUpper` both return `False`. Functions affected: + `Text.Megaparsec.Char.char'`. + +* Renamed `getPosition` to `getSourcePos`. + +* Renamed `getTokensProcessed` to `getOffset`, `setTokensProcessed` to + `setOffset`. + +* Dropped `getTabWidth` and `setTabWidth` because tab width is irrelevant to + parsing process now, it's only relevant for pretty-printing of parse + errors, which is handled separately. + +* Added and `withParsecT` in `Text.Megaparsec.Internal` to allow changing + the type of the custom data component in parse errors. + +### Parser state and input stream + +* Dropped stacks of source positions. Accordingly, the functions + `pushPosition` and `popPosition` from `Text.Megaparsec` and + `sourcePosStackPretty` from `Text.Megaparsec.Error` were removed. The + reason for this simplification is that I could not find any code that uses + the feature and it makes manipulation of source positions hairy. + +* Introduced `PosState` for calculating `SourcePos` from offsets and getting + offending line for displaying on pretty-printing of parse errors. It's now + contained in both `State` and `ParseErrorBundle`. + +* Dropped `positionAt1`, `positionAtN`, `advance1`, and `advanceN` methods + from `Stream`. They are no longer necessary because `reachOffset` (and its + specialized version `reachOffsetNoLine`) takes care of `SourcePos` + calculation. + +### Parse errors + +* `ParseError` now contains raw offset in input stream instead of + `SourcePos`. `errorPos` was dropped from `Text.Megaparsec.Error`. + +* `ParseError` is now parametrized over stream type `s` instead of token + type `t`. + +* Introduced `ParseErrorBundle` which contains one or more `ParseError` + equipped with all information that is necessary to pretty-print them + together with offending lines from the input stream. Functions like + `runParser` now return `ParseErrorBundle` instead of plain `ParseError`. + + By default there will be only one `ParseError` in such a bundle, but it's + possible to add more parse errors to a bundle manually. During + pretty-printing, the input stream will be traversed only once. + +* The primary function for pretty-printing of parse + errors—`errorBundlePretty` always prints offending lines now. + `parseErrorPretty` is still there, but it probably won't see a lot of use + from now on. `parseErrorPretty'` and `parseErrorPretty_` were removed. + `parseTest'` was removed because `parseTest` always prints offending lines + now. + +* Added `attachSourcePos` function in `Text.Megaparsec.Error`. + +* The `ShowToken` type class has been removed and its method `showTokens` + now lives in the `Stream` type class. + +* The `LineToken` type class is no longer necessary because the new method + `reachOffset` of the type class `Stream` does its job. + +* In `Text.Megaparsec.Error` the following functions were added: + `mapParseError`, `errorOffset`. + +* Implemented continuous highlighting in parse errors. For this we added the + `errorComponentLen` method to the `ShowErrorComponent` type class. + +### Parse error builder + +* The functions `err` and `errFancy` now accept offsets at which the parse + errors are expected to have happened, i.e. `Int`s. Thus `posI` and `posN` + are no longer necessary and were removed. + +* `ET` is now parametrized over the type of stream `s` instead of token type + `t`. + +* Combinators like `utoks` and `etoks` now accept chunks of input stream + directly, i.e. `Tokens s` instead of `[Token s]` which should be more + natural and convenient. + +## Megaparsec 6.5.0 + +* Added `Text.Megaparsec.Internal`, which exposes some internal data + structures and data constructor of `ParsecT`. + +## Megaparsec 6.4.1 + +* `scientific` now correctly backtracks after attempting to parse fractional + and exponent parts of a number. `float` correctly backtracks after + attempting to parse optional exponent part (when it comes after fractional + part, otherwise it's obligatory). + +## Megaparsec 6.4.0 + +* `Text.Megaparsec` now re-exports `Control.Monad.Combinators` instead of + `Control.Applicative.Combinators` from `parser-combinators` because the + monadic counterparts of the familiar combinators are more efficient and + not as leaky. + + This may cause minor breakage in certain cases: + + * You import `Control.Applicative` and in that case there will be a name + conflict between `Control.Applicative.many` and + `Control.Monad.Combinator.many` now (the same for `some`). + + * You define a polymorphic helper in terms of combinator(s) from + `Control.Applicative.Combinators` and use `Applicative` or `Alternative` + constraint. In this case you'll have to adjust the constraint to be + `Monad` or `MonadPlus` respectively. + + Also note that the new `Control.Monad.Combinators` module we re-export now + re-exports `empty` from `Control.Applicative`. + +* Fix the `atEnd` parser. It now does not produce hints, so when you use it, + it won't contribute to the “expecting end of input” component of parse + error. + +## Megaparsec 6.3.0 + +* Added an `IsString` instance for `ParsecT`. Now it is possible to + write `"abc"` rather than `string "abc"`. + +* Added the `customFailure` combinator, which is a special case of + `fancyFailure`. + +* Made implementation of `sconcat` and `mconcat` of `ParsecT` more + efficient. + +## Megaparsec 6.2.0 + +* `float` in `Text.Megaparsec.Char.Lexer` and `Text.Megaparsec.Byte.Lexer` + now does not accept plain integers. This is the behavior we had in version + 5 of the library. + +## Megaparsec 6.1.1 + +* Fixed the bug when `tokens` used `cok` continuation even when matching an + empty chunk. Now it correctly uses `eok` in this case. + +## Megaparsec 6.1.0 + +* Improved rendering of offending line in `parseErrorPretty'` in the + presence of tab characters. + +* Added `parseErrorPretty_`, which is just like `parseErrorPretty'` but + allows to specify tab width to use. + +* Adjusted hint generation so when we backtrack a consuming parser with + `try`, we do not create hints from its parse error (because it's further + in input stream!). This was a quite subtle bug that stayed unnoticed for + several years apparently. + +## Megaparsec 6.0.2 + +* Allow `parser-combinators-0.2.0`. + +## Megaparsec 6.0.1 + +* Fixed a typo in `README.md`. + +* Added some text that clarifies how to parametrize the `ParseError` type. + +## Megaparsec 6.0.0 + +### General + +* Re-organized the module hierarchy. Some modules such as + `Text.Megaparsec.Prim` do not exist anymore. Stream definitions were moved + to `Text.Megaparsec.Stream`. Generic combinators are now re-exported from + the `Control.Applicative.Combinators` from the package + `parser-combinators`. Just import `Text.Megaparsec` and you should be OK. + Add `Text.Megaparsec.Char` if you are working with a stream of `Char`s or + `Text.Megaparsec.Byte` if you intend to parse binary data, then add + qualified modules you need (permutation parsing, lexing, expression + parsing, etc.). `Text.Megaparsec.Lexer` was renamed to + `Text.Megaparsec.Char.Lexer` because many functions in it has the `Token s + ~ Char` constraint. There is also `Text.Megaparsec.Byte.Lexer` now, + although it has fewer functions. + +* Dropped per-stream modules, the `Parser` type synonym is to be defined + manually by user. + +* Added a `MonadFix` instance for `ParsecT`. + +* More lightweight dependency tree, dropped `exceptions` and `QuickCheck` + dependencies. + +* Added dependency on `case-insensitive`. + +### Source positions + +* Now `Pos` contains an `Int` inside, not `Word`. + +* Dropped `unsafePos` and changed type of `mkPos` so it throws from pure + code if its argument is not a positive `Int`. + +* Added `pos1` constant that represents the `Pos` with value 1 inside. + +* Made `InvalidPosException` contain the invalid `Int` value that was passed + to `mkPos`. + +### Parse errors + +* Changed the definition of `ParseError` to have separate data constructors + for “trivial” errors (unexpected/expected tokens) and “fancy” errors + (everything else). + +* Removed the `ErrorComponent` type class, added `ErrorFancy` instead. + `ErrorFancy` is a sum type which can represent `fail` messages, incorrect + indentation, and custom data (we use `Void` for that by default to + “disable” it). This is better than the typeclass-based approach because + every instance of `ErrorComponent` needed to have constructors for `fail` + and indentation massages anyway, leading to duplication of code (for + example for parse error component rendering). + +* Added `Functor` instances for `ErrorItem` and `ErrorFancy`. + +* Added the function `errorPos` to get error positions from `ParseError` + (previously it was a record selector in `ParseError`). + +* Control characters in parse error are displayed in a readable form even + when they are part of strings, for example: `{` (`{` followed by + the newline character). Previously control characters were rendered in + readable form only as standalone tokens. + +* Added `Text.Megaparsec.Error.Builder` module to help construct + `ParseError`s easily. It is useful for testing and debugging. Previously + we had something like that in the `hspec-megaparsec` package, but it does + not hurt to ship it with the library. + +* Added `parseErrorPretty'` allowing to display offending line in parse + errors. + +* Added `LineToken` type class for tokens that support operations necessary + for selecting and displaying relevant line of input (used in + `parseErrorPretty'`). + +* Added `parseTest'` function that is just like `parseTest`, but also prints + offending line in parse errors. This is powered by the new + `parseErrorPretty'`. + +### Stream + +* Introduced the new `Text.Megaparsec.Stream` module that is the home of + `Stream` type class. In version 6, the type class has been extended + significantly to improve performance and make some combinators more + general. + +### Combinators + +* Changed signatures of `failure` and `token`, they only can signal trivial + errors now. + +* Added a new method of `MonadParsec` type class called `fancyFailure` for + signalling non-trivial failures. Signatures of some functions (`failure`, + `token`) have been changed accordingly. + +* Added `takeWhileP`, `takeWhile1P` and `takeP` to `MonadParsec`. + +* Added `takeRest` non-primitive combinator to consume the rest of input. + +* Added `atEnd` which returns `True` when end of input has been reached. + +* Dropped `oneOf'` and `noneOf'` from `Text.Megaparsec.Char`. These were + seldom (if ever) used and are easily re-implemented. + +* Added `notChar` in `Text.Megaparsec.Char`. + +* Added `space1` in `Text.Megaparsec.Char`. This parser is like `space` but + requires at least one space character to be present to succeed. + +* Added new module `Text.Megaparsec.Byte`, which is similar to + `Text.Megaparsec.Char`, but for token streams of the type `Word8` instead + of `Char`. + +* `integer` was dropped from `Text.Megaparsec.Char.Lexer`. Use `decimal` + instead. + +* `number` was dropped from `Text.Megaparsec.Char.Lexer`. Use `scientific` + instead. + +* `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return + type and can be used to parse any instance of `Integral`. + +* `float` is now polymorphic in its return type and can be used to parse any + instance of `RealFloat`. + +* Added new module `Text.Megaparsec.Byte.Lexer`, which provides some + functions (white space and numeric helpers) from + `Text.Megaparsec.Char.Lexer` for streams with token type `Word8`. + ## Megaparsec 5.3.1 * Various updates to the docs. @@ -397,7 +964,7 @@ ### Built-in combinators * All built-in combinators in `Text.Megaparsec.Combinator` now work with any - instance of `Alternative` (some of them even with `Applicaitve`). + instance of `Alternative` (some of them even with `Applicative`). * Added more powerful `count'` parser. This parser can be told to parse from `m` to `n` occurrences of some thing. `count` is defined in terms of diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,5 +1,5 @@ -Copyright © 2015–2017 Megaparsec contributors
-Copyright © 2007 Paolo Martini
+Copyright © 2015–present Megaparsec contributors\ +Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,16 +4,13 @@ [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec) -[![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) -[![Coverage Status](https://coveralls.io/repos/mrkkrp/megaparsec/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/megaparsec?branch=master) +[![CI](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml) * [Features](#features) * [Core features](#core-features) * [Error messages](#error-messages) - * [Alex and Happy support](#alex-and-happy-support) - * [Character parsing](#character-parsing) - * [Permutation parsing](#permutation-parsing) - * [Expression parsing](#expression-parsing) + * [External lexers](#external-lexers) + * [Character and binary parsing](#character-and-binary-parsing) * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials) @@ -23,205 +20,154 @@ * [Megaparsec vs Parsec](#megaparsec-vs-parsec) * [Megaparsec vs Trifecta](#megaparsec-vs-trifecta) * [Megaparsec vs Earley](#megaparsec-vs-earley) - * [Megaparsec vs Parsers](#megaparsec-vs-parsers) * [Related packages](#related-packages) -* [Links to announcements](#links-to-announcements) -* [Authors](#authors) +* [Prominent projects that use Megaparsec](#prominent-projects-that-use-megaparsec) +* [Links to announcements and blog posts](#links-to-announcements-and-blog-posts) * [Contribution](#contribution) * [License](#license) This is an industrial-strength monadic parser combinator library. Megaparsec -is a fork of [Parsec](https://github.com/aslatter/parsec) library originally -written by Daan Leijen. +is a feature-rich package that tries to find a nice balance between speed, +flexibility, and quality of parse errors. ## Features -This project provides flexible solutions to satisfy common parsing needs. -The section describes them shortly. If you're looking for comprehensive +The project provides flexible solutions to satisfy common parsing needs. The +section describes them shortly. If you're looking for comprehensive documentation, see the [section about documentation](#documentation). ### Core features The package is built around `MonadParsec`, an MTL-style monad transformer. -All tools and features work with all instances of `MonadParsec`. You can -achieve various effects combining monad transformers, i.e. building monad -stack. Since the standard common monad transformers like `WriterT`, -`StateT`, `ReaderT` and others are instances of the `MonadParsec` type -class, you can wrap `ParsecT` *in* these monads, achieving, for example, -backtracking state. +Most features work with all instances of `MonadParsec`. One can achieve +various effects combining monad transformers, i.e. building a monadic stack. +Since the common monad transformers like `WriterT`, `StateT`, `ReaderT` and +others are instances of the `MonadParsec` type class, one can also wrap +`ParsecT` *in* these monads, achieving, for example, backtracking state. On the other hand `ParsecT` is an instance of many type classes as well. The most useful ones are `Monad`, `Applicative`, `Alternative`, and `MonadParsec`. -The module -[`Text.Megaparsec.Combinator`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Combinator.html) (its -functions are included in `Text.Megaparsec`) contains traditional, general -combinators that work with instances of `Applicative` and `Alternative`. - -Let's enumerate methods of the `MonadParsec` type class. The class abstracts -primitive functions of Megaparsec parsing. The rest of the library is built -via combination of these primitives: - -* `failure` allows to fail reporting an arbitrary parse error. - -* `label` allows to add a “label” to a parser, so if it fails the user will - see the label instead of an automatically deduced expected token. - -* `hidden` hides a parser from error messages altogether. This is the - recommended way to hide things, prefer it to the `label ""` approach. - -* `try` enables backtracking in parsing. - -* `lookAhead` allows to parse input without consuming it. - -* `notFollowedBy` succeeds when its argument fails and does not consume - input. +Megaparsec includes all functionality that is typically available in +Parsec-like libraries and also features some special combinators: -* `withRecovery` allows to recover from parse errors “on-the-fly” and +* `parseError` allows us to end parsing and report an arbitrary parse error. +* `withRecovery` can be used to recover from parse errors “on-the-fly” and continue parsing. Once parsing is finished, several parse errors may be reported or ignored altogether. - -* `observing` allows to “observe” parse errors without ending parsing (they - are returned in `Left`, while normal results are wrapped in `Right`). - -* `eof` only succeeds at the end of input. - -* `token` is used to parse a single token. - -* `tokens` makes it easy to parse several tokens in a row. +* `observing` makes it possible to “observe” parse errors without ending + parsing. -* `getParserState` returns the full parser state. +In addition to that, Megaparsec features high-performance combinators +similar to those found in [Attoparsec][attoparsec]: -* `updateParserState` applies a given function on the parser state. +* `tokens` makes it easy to parse several tokens in a row (`string` and + `string'` are built on top of this primitive). This is about 100 times + faster than matching a string token by token. `tokens` returns “chunk” of + original input, meaning that if you parse `Text`, it'll return `Text` + without repacking. +* `takeWhile` and `takeWhile1` are about 150 times faster than approaches + involving `many`, `manyTill` and other similar combinators. +* `takeP` allows us to grab n tokens from the stream and returns them as a + “chunk” of the stream. -This list of core functions is longer than in some other libraries. Our goal -is efficient, readable implementations, and rich functionality, not minimal -number of primitive combinators. You can read the comprehensive description -of every primitive function in -[Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html). +Megaparsec is about as fast as Attoparsec if you write your parser carefully +(see also [the section about performance](#performance)). -Megaparsec can currently work with the following types of input stream +The library can currently work with the following types of input stream out-of-the-box: -* `String` = `[Char]` +* `String = [Char]` * `ByteString` (strict and lazy) * `Text` (strict and lazy) -It's also simple to make it work with custom token streams, and Megaparsec -users have done so many times with great success. +It's also possible to make it work with custom token streams by making them +an instance of the `Stream` type class. ### Error messages -Megaparsec 5 introduces well-typed error messages and the ability to use -custom data types to adjust the library to specific domain of interest. No -need to use a shapeless bunch of strings anymore. +* Megaparsec has typed error messages and the ability to signal custom parse + errors that better suit the user's domain of interest. -The default error component (`Dec`) has constructors corresponding to the -`fail` function and indentation-related error messages. It is a decent -option that should work out-of-box for most parsing needs, while you are -free to use your own custom error component when necessary. +* Since version 8, the location of parse errors can independent of current + offset in the input stream. It is useful when you want a parse error to + point to a particular position after performing some checks. -This new design allowed Megaparsec 5 to have much more helpful error -messages for indentation-sensitive parsing instead of the plain “incorrect -indentation” phrase. +* Instead of a single parse error Megaparsec produces so-called + `ParseErrorBundle` data type that helps to manage multi-error messages and + pretty-print them. Since version 8, reporting multiple parse errors at + once has become easier. -### Alex and Happy support +### External lexers -Megaparsec works well with streams of tokens produced by tools like -Alex/Happy. Megaparsec 5 adds `updatePos` method to `Stream` type class that -gives you full control over textual positions that are used to report token -positions in error messages. You can update current position on per -character basis or extract it from token. +Megaparsec works well with streams of tokens produced by tools like Alex. +The design of the `Stream` type class has been changed significantly in the +recent versions, but user can still work with custom streams of tokens. -### Character parsing +### Character and binary parsing Megaparsec has decent support for Unicode-aware character parsing. Functions -for character parsing live in the -[`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) -module (they all are included in `Text.Megaparsec`). The functions can be -divided into several categories: - -* *Simple parsers*—parsers that parse certain character or several - characters of the same kind. This includes `newline`, `crlf`, `eol`, - `tab`, and `space`. - -* *Parsers corresponding to categories of characters* parse single character - that belongs to certain category of characters, for example: - `controlChar`, `spaceChar`, `upperChar`, `lowerChar`, `printChar`, - `digitChar`, and others. - -* *General parsers* that allow you to parse a single character you specify - or one of the given characters, or any character except for the given - ones, or character satisfying given predicate. Case-insensitive versions - of the parsers are available. - -* *Parsers for sequences of characters* parse strings. Case-sensitive - `string` parser is available as well as case-insensitive `string'`. - -### Permutation parsing - -For those who are interested in parsing of permutation phrases, there -is [`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html). -You have to import the module explicitly, it's not included in the -`Text.Megaparsec` module. - -### Expression parsing - -Megaparsec has a solution for parsing of expressions. Take a look at -[`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html). You have to import the module explicitly, it's not -included in the `Text.Megaparsec`. - -Given a table of operators that describes their fixity and precedence, you -can construct a parser that will parse any expression involving the -operators. See documentation for comprehensive description of how it works. +for character parsing live in the [`Text.Megaparsec.Char`][tm-char] module. +Similarly, there is [`Text.Megaparsec.Byte`][tm-byte] module for parsing +streams of bytes. ### Lexer -[`Text.Megaparsec.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Lexer.html) -is a module that should help you write your lexer. If you have used `Parsec` -in the past, this module “fixes” its particularly inflexible -`Text.Parsec.Token`. +[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is a module that should help +you write your lexer. If you have used `Parsec` in the past, this module +“fixes” its particularly inflexible `Text.Parsec.Token`. -`Text.Megaparsec.Lexer` is intended to be imported via a qualified import, -it's not included in `Text.Megaparsec`. The module doesn't impose how you -should write your parser, but certain approaches may be more elegant than -others. An especially important theme is parsing of white space, comments, -and indentation. +[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is intended to be imported +using a qualified import, it's not included in [`Text.Megaparsec`][tm]. The +module doesn't impose how you should write your parser, but certain +approaches may be more elegant than others. An especially important theme is +parsing of white space, comments, and indentation. -The design of the module allows you quickly solve simple tasks and doesn't -get in your way when you want to implement something less standard. +The design of the module allows one quickly solve simple tasks and doesn't +get in the way when the need to implement something less standard arises. -Since Megaparsec 5, all tools for indentation-sensitive parsing are -available in `Text.Megaparsec.Lexer` module—no third party packages -required. +[`Text.Megaparsec.Byte.Lexer`][tm-byte-lexer] is also available for users +who wish to parse binary data. ## Documentation -Megaparsec is well-documented. All functions and data-types are thoroughly -described. We pay attention to avoid outdated info or unclear phrases in our -documentation. See the [current version of Megaparsec documentation on -Hackage](https://hackage.haskell.org/package/megaparsec) for yourself. +Megaparsec is well-documented. See the [current version of Megaparsec +documentation on Hackage][hackage]. ## Tutorials -You can find Megaparsec tutorials -[here](https://markkarpov.com/learn-haskell.html#megaparsec-tutorials). They -should provide sufficient guidance to help you to start with your parsing -tasks. The site also has instructions and tips for Parsec users who decide -to migrate to Megaparsec. +You can find the most complete Megaparsec tutorial [here][the-tutorial]. It +should provide sufficient guidance to help you start with your parsing +tasks. ## Performance -Despite being quite flexible, Megaparsec is also faster than Parsec. The -repository includes benchmarks that can be easily used to compare Megaparsec -and Parsec. In most cases Megaparsec is faster, sometimes dramatically -faster. If you happen to have some other benchmarks, I would appreciate if -you add Megaparsec to them and let me know how it performs. +Despite being flexible, Megaparsec is also fast. Here is how Megaparsec +compares to [Attoparsec][attoparsec] (the fastest widely used parsing +library in the Haskell ecosystem): -If you think your Megaparsec parser is not efficient enough, take a look -at [these instructions](https://markkarpov.com/megaparsec/writing-a-fast-parser.html). +Test case | Execution time | Allocated | Max residency +------------------|---------------:|----------:|-------------: +CSV (Attoparsec) | 76.50 μs | 397,784 | 10,544 +CSV (Megaparsec) | 64.69 μs | 352,408 | 9,104 +Log (Attoparsec) | 302.8 μs | 1,150,032 | 10,912 +Log (Megaparsec) | 337.8 μs | 1,246,496 | 10,912 +JSON (Attoparsec) | 18.20 μs | 128,368 | 9,032 +JSON (Megaparsec) | 25.45 μs | 203,824 | 9,176 +You can run the benchmarks yourself by executing: + +``` +$ nix-build -A benches.parsers-bench +$ cd result/bench +$ ./bench-memory +$ ./bench-speed +``` + +More information about benchmarking and development can be found +[here][hacking]. + ## Comparison with other solutions There are quite a few libraries that can be used for parsing in Haskell, @@ -229,198 +175,178 @@ ### Megaparsec vs Attoparsec -[Attoparsec](https://github.com/bos/attoparsec) is another prominent Haskell -library for parsing. Although the both libraries deal with parsing, it's -usually easy to decide which you will need in particular project: +[Attoparsec][attoparsec] is another prominent Haskell library for parsing. +Although both libraries deal with parsing, it's usually easy to decide which +you will need in particular project: -* *Attoparsec* is much faster but not that feature-rich. It should be used - when you want to process large amounts of data where performance matters - more than quality of error messages. +* *Attoparsec* is sometimes faster but not that feature-rich. It should be + used when you want to process large amounts of data where performance + matters more than quality of error messages. * *Megaparsec* is good for parsing of source code or other human-readable - texts. It has better error messages and it's implemented as monad + texts. It has better error messages and it's implemented as a monad transformer. -So, if you work with something human-readable where size of input data is -usually not huge, just go with Megaparsec, otherwise Attoparsec may be a -better choice. +So, if you work with something human-readable where the size of input data +is moderate, it makes sense to go with Megaparsec, otherwise Attoparsec may +be a better choice. ### Megaparsec vs Parsec -Since Megaparsec is a fork of Parsec, we are bound to list the main -differences between the two libraries: +Since Megaparsec is a fork of [Parsec][parsec], we are bound to list the +main differences between the two libraries: -* Better error messages. We test our error messages using dense QuickCheck - tests. Good error messages are just as important for us as correct return - values of our parsers. Megaparsec will be especially useful if you write a - compiler or an interpreter for some language. +* Better error messages. Megaparsec has typed error messages and custom + error messages, it can also report multiple parse errors at once. -* Some quirks and “buggy features” (as well as plain bugs) of original - Parsec are fixed. There is no undocumented surprising stuff in Megaparsec. +* Megaparsec can show the line on which parse error happened as part of + parse error. This makes it a lot easier to figure out where the error + happened. -* Better support for Unicode parsing in `Text.Megaparsec.Char`. +* Some quirks and bugs of Parsec are fixed. +* Better support for Unicode parsing in [`Text.Megaparsec.Char`][tm-char]. + * Megaparsec has more powerful combinators and can parse languages where indentation matters. -* Comprehensive QuickCheck test suite covering nearly 100% of our code. - -* We have benchmarks to detect performance regressions. - -* Better documentation, with 100% of functions covered, without typos and - obsolete information, with working examples. Megaparsec's documentation is - well-structured and doesn't contain things useless to end users. - -* Megaparsec's code is clearer and doesn't contain “magic” found in original - Parsec. - -* Megaparsec has well-typed error messages and custom error messages. +* Better documentation. * Megaparsec can recover from parse errors “on the fly” and continue parsing. -* Megaparsec allows to conditionally process parse errors *inside your - parser* before parsing is finished. In particular, it's possible to define - regions in which parse errors, should they happen, will get a “context - tag”, e.g. we could build a context stack like “in function definition - foo”, “in expression x”, etc. This is not possible with Parsec. - -* Megaparsec is faster. +* Megaparsec allows us to conditionally process parse errors inside a + running parser. In particular, it's possible to define regions in which + parse errors, should they happen, will get a “context tag”, e.g. we could + build a context stack like “in function definition foo”, “in expression + x”, etc. -* Megaparsec is ~~better~~ supported. +* Megaparsec is faster and supports efficient operations `tokens`, + `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec. If you want to see a detailed change log, `CHANGELOG.md` may be helpful. -Also see [this original announcement](https://notehub.org/w7037) for another +Also see [this original announcement][original-announcement] for another comparison. -To be honest Parsec's development has seemingly stagnated. It has no test -suite (only three per-bug tests), and all its releases beginning from -version 3.1.2 (according or its change log) were about introducing and -fixing regressions. Parsec is old and somewhat famous in the Haskell -community, so we understand there will be some kind of inertia, but we -advise you use Megaparsec from now on because it solves many problems of the -original Parsec project. If you think you still have a reason to use -original Parsec, open an issue. - ### Megaparsec vs Trifecta -[Trifecta](https://hackage.haskell.org/package/trifecta) is another Haskell -library featuring good error messages. Like some other projects of Edward -Kmett, it's probably good, but also under-documented, and has -unfixed [bugs and flaws](https://github.com/ekmett/trifecta/issues) that -Edward is too busy to fix (simply a fact, no offense intended). Other -reasons one may question choice of Trifecta is his/her parsing library: +[Trifecta][trifecta] is another Haskell library featuring good error +messages. These are the common reasons why Trifecta may be problematic to +use: * Complicated, doesn't have any tutorials available, and documentation - doesn't help at all. + doesn't help much. * Trifecta can parse `String` and `ByteString` natively, but not `Text`. -* Trifecta's error messages may be different with their own features, but - certainly not as flexible as Megaparsec's error messages in the latest - versions. +* Depends on `lens`, which is a very heavy dependency. If you're not into + `lens`, you may not like the API. -* Depends on `lens`. This means you'll pull in half of Hackage as transitive - dependencies. Also if you're not into `lens` and would like to keep your - code “vanilla”, you may not like the API. +[Idris][idris] has switched from Trifecta to Megaparsec which allowed it to +[have better error messages and fewer dependencies][idris-testimony]. ### Megaparsec vs Earley -[Earley](https://hackage.haskell.org/package/Earley) is a newer library that -allows to safely (it your code compiles, then it probably works) parse +[Earley][earley] is a newer library that allows us to safely parse context-free grammars (CFG). Megaparsec is a lower-level library compared to -Earley, but there are still enough reasons to choose it over Earley: +Earley, but there are still enough reasons to choose it: * Megaparsec is faster. * Your grammar may be not context-free or you may want introduce some sort of state to the parsing process. Almost all non-trivial parsers require - something of this sort. Even if your grammar is context-free, state may - allow to add some additional niceties. Earley does not support that. + state. Even if your grammar is context-free, state may allow for + additional niceties. Earley does not support that. * Megaparsec's error messages are more flexible allowing to include arbitrary data in them, return multiple error messages, mark regions that affect any error that happens in those regions, etc. -* The approach Earley uses differs from the conventional monadic parsing. If - you work not alone, chances people you work with, especially beginners - will be much more productive with libraries taking more traditional path - to parsing like Megaparsec. - -IOW, Megaparsec is less safe but also more powerful. - -### Megaparsec vs Parsers - -There is [Parsers](https://hackage.haskell.org/package/parsers) package, -which is great. You can use it with Megaparsec or Parsec, but consider the -following: - -* It depends on Attoparsec, Parsec, and Trifecta, which means you always - grab half of Hackage as transitive dependencies by using it. This is - ridiculous, by the way, because this package is supposed to be useful for - parser builders, so they can write basic core functionality and get the - rest “for free”. - -* It currently has a ~~bug~~ feature in definition of `lookAhead` for - various monad transformers like `StateT`, etc. which is visible when you - create backtracking state via monad stack, not via built-in features. The - feature makes it so `lookAhead` will backtrack your parser state but not - your custom state added via `StateT`. Kmett thinks this behavior is - better. - -We intended to use Parsers library in Megaparsec at some point, but aside -from already mentioned flaws the library has different conventions for -naming of things, different set of “core” functions, etc., different -approach to lexing. So it didn't happen, Megaparsec has minimal -dependencies, it is feature-rich and self-contained. +In other words, Megaparsec is less safe but also more powerful. ## Related packages -The following packages are designed to be used with Megaparsec: +The following packages are designed to be used with Megaparsec (open a PR if +you want to add something to the list): * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities - for testing Megaparsec parsers with - with [Hspec](https://hackage.haskell.org/package/hspec). - + for testing Megaparsec parsers with with + [Hspec](https://hackage.haskell.org/package/hspec). +* [`replace-megaparsec`](https://hackage.haskell.org/package/replace-megaparsec)—Stream + editing and find-and-replace with Megaparsec. * [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec)—Megaparsec - parser of CSV files that plays nicely - with [Cassava](https://hackage.haskell.org/package/cassava). - + parser of CSV files that plays nicely with + [Cassava](https://hackage.haskell.org/package/cassava). * [`tagsoup-megaparsec`](https://hackage.haskell.org/package/tagsoup-megaparsec)—a - library for easily - using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token - type in Megaparsec. + library for easily using + [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in + Megaparsec. +* [`parser-combinators`](https://hackage.haskell.org/package/parser-combinators)—provides permutation and expression parsers [previously bundled with Megaparsec](https://markkarpov.com/post/megaparsec-7.html#parsercombinators-grows-megaparsec-shrinks). +* [`faster-megaparsec`](https://hackage.haskell.org/package/faster-megaparsec)—speeds up parsing + by trying a simple `MonadParsec` instance and falls back to `ParsecT` to report errors. -## Links to announcements +## Prominent projects that use Megaparsec +Some prominent projects that use Megaparsec: + +* [Idris](https://github.com/idris-lang/Idris-dev)—a general-purpose + functional programming language with dependent types +* [Dhall](https://github.com/dhall-lang/dhall-haskell)—an advanced + configuration language +* [hnix](https://github.com/haskell-nix/hnix)—re-implementation of the Nix + language in Haskell +* [Hledger](https://github.com/simonmichael/hledger)—an accounting tool +* [MMark](https://github.com/mmark-md/mmark)—strict markdown processor for + writers + +## Links to announcements and blog posts + Here are some blog posts mainly announcing new features of the project and describing what sort of things are now possible: +* [Megaparsec 8](https://markkarpov.com/post/megaparsec-8.html) +* [Megaparsec 7](https://markkarpov.com/post/megaparsec-7.html) +* [Evolution of error messages](https://markkarpov.com/post/evolution-of-error-messages.html) +* [A major upgrade to Megaparsec: more speed, more power](https://markkarpov.com/post/megaparsec-more-speed-more-power.html) * [Latest additions to Megaparsec](https://markkarpov.com/post/latest-additions-to-megaparsec.html) * [Announcing Megaparsec 5](https://markkarpov.com/post/announcing-megaparsec-5.html) * [Megaparsec 4 and 5](https://markkarpov.com/post/megaparsec-4-and-5.html) -* [The original Megaparsec 4.0.0 announcement](https://notehub.org/w7037) - -## Authors - -The project was started and is currently maintained by Mark Karpov. You can -find the complete list of contributors in the `AUTHORS.md` file in the -official repository of the project. Thanks to all the people who propose -features and ideas, although they are not in `AUTHORS.md`, without them -Megaparsec would not be that good. +* [The original Megaparsec 4.0.0 announcement][original-announcement] ## Contribution Issues (bugs, feature requests or otherwise feedback) may be reported in -[the GitHub issue tracker for this project](https://github.com/mrkkrp/megaparsec/issues). +[the GitHub issue tracker for this +project](https://github.com/mrkkrp/megaparsec/issues). -Pull requests are also welcome (and yes, they will get attention and will be -merged quickly if they are good). +Pull requests are also welcome. If you would like to contribute to the +project, you may find [this document][hacking] helpful. ## License -Copyright © 2015–2017 Megaparsec contributors
-Copyright © 2007 Paolo Martini
+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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -1,6 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec --- Copyright : © 2015–2017 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -11,207 +20,645 @@ -- -- This module includes everything you need to get started writing a parser. -- If you are new to Megaparsec and don't know where to begin, take a look --- at the tutorials . --- --- By default this module is set up to parse character data. If you'd like --- to parse the result of your own tokenizer you should start with the --- following imports: +-- at the tutorial . -- --- > import Text.Megaparsec.Prim --- > import Text.Megaparsec.Combinator +-- In addition to the "Text.Megaparsec" module, which exports and re-exports +-- almost everything that you may need, we advise to import +-- "Text.Megaparsec.Char" if you plan to work with a stream of 'Char' tokens +-- or "Text.Megaparsec.Byte" if you intend to parse binary data. -- --- Then you can implement your own version of 'satisfy' on top of the --- 'token' primitive, etc. +-- It is common to start working with the library by defining a type synonym +-- like this: -- --- The typical import section looks like this: +-- > type Parser = Parsec Void Text +-- > ^ ^ +-- > | | +-- > Custom error component Input stream type -- --- > import Text.Megaparsec --- > import Text.Megaparsec.String --- > -- import Text.Megaparsec.ByteString --- > -- import Text.Megaparsec.ByteString.Lazy --- > -- import Text.Megaparsec.Text --- > -- import Text.Megaparsec.Text.Lazy +-- Then you can write type signatures like @Parser 'Int'@—for a parser that +-- returns an 'Int' for example. -- --- As you can see the second import depends on the data type you want to use --- as input stream. It just defines the useful type-synonym @Parser@. +-- Similarly (since it's known to cause confusion), you should use +-- 'ParseErrorBundle' type parametrized like this: -- --- Megaparsec 5 uses some type-level machinery to provide flexibility --- without compromising on type safety. Thus type signatures are sometimes --- necessary to avoid ambiguous types. If you're seeing a error message that --- reads like “Ambiguous type variable @e0@ arising from … prevents the --- constraint @(ErrorComponent e0)@ from being resolved”, you need to give --- an explicit signature to your parser to resolve the ambiguity. It's a --- good idea to provide type signatures for all top-level definitions. +-- > ParseErrorBundle Text Void +-- > ^ ^ +-- > | | +-- > Input stream type Custom error component (the same you used in Parser) -- --- Megaparsec is capable of a lot. Apart from this standard functionality --- you can parse permutation phrases with "Text.Megaparsec.Perm", --- expressions with "Text.Megaparsec.Expr", and even entire languages with --- "Text.Megaparsec.Lexer". These modules should be imported explicitly --- along with the two modules mentioned above. - +-- Megaparsec uses some type-level machinery to provide flexibility without +-- compromising on type safety. Thus type signatures are sometimes necessary +-- to avoid ambiguous types. If you're seeing an error message that reads +-- like “Type variable @e0@ is ambiguous …”, you need to give an explicit +-- signature to your parser to resolve the ambiguity. It's a good idea to +-- provide type signatures for all top-level definitions. module Text.Megaparsec - ( -- * Running parser - Parsec - , ParsecT - , parse - , parseMaybe - , parseTest - , runParser - , runParser' - , runParserT - , runParserT' - -- * Combinators - , (A.<|>) - -- $assocbo - , A.many - -- $many - , A.some - -- $some - , A.optional - -- $optional - , unexpected - , match - , region - , failure - , () - , label - , hidden - , try - , lookAhead - , notFollowedBy - , withRecovery - , observing - , eof - , token - , tokens - , between - , choice - , count - , count' - , eitherP - , endBy - , endBy1 - , manyTill - , someTill - , option - , sepBy - , sepBy1 - , sepEndBy - , sepEndBy1 - , skipMany - , skipSome - -- * Character parsing - , newline - , crlf - , eol - , tab - , space - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , octDigitChar - , hexDigitChar - , markChar - , numberChar - , punctuationChar - , symbolChar - , separatorChar - , asciiChar - , latin1Char - , charCategory - , char - , char' - , anyChar - , oneOf - , oneOf' - , noneOf - , noneOf' - , satisfy - , string - , string' - -- * Textual source position - , Pos - , mkPos - , unPos - , unsafePos - , InvalidPosException (..) - , SourcePos (..) - , initialPos - , sourcePosPretty - -- * Error messages - , ErrorItem (..) - , ErrorComponent (..) - , Dec (..) - , ParseError (..) - , ShowToken (..) - , ShowErrorComponent (..) - , parseErrorPretty - -- * Debugging - , dbg - -- * Low-level operations - , Stream (..) - , State (..) - , getInput - , setInput - , getPosition - , getNextTokenPosition - , setPosition - , pushPosition - , popPosition - , getTokensProcessed - , setTokensProcessed - , getTabWidth - , setTabWidth - , getParserState - , setParserState - , updateParserState ) -where + ( -- * Re-exports + -- $reexports + module Text.Megaparsec.Pos, + module Text.Megaparsec.Error, + module Text.Megaparsec.Stream, + module Control.Monad.Combinators, -import qualified Control.Applicative as A + -- * Data types + State (..), + PosState (..), + Parsec, + ParsecT, -import Text.Megaparsec.Char -import Text.Megaparsec.Combinator + -- * Running parser + parse, + parseMaybe, + parseTest, + runParser, + runParser', + runParserT, + runParserT', + + -- * Primitive combinators + MonadParsec (..), + + -- * Signaling parse errors + -- $parse-errors + failure, + fancyFailure, + unexpected, + customFailure, + region, + registerParseError, + registerFailure, + registerFancyFailure, + + -- * Derivatives of primitive combinators + single, + satisfy, + anySingle, + anySingleBut, + oneOf, + noneOf, + chunk, + (), + match, + takeRest, + atEnd, + + -- * Parser state combinators + getInput, + setInput, + getSourcePos, + getOffset, + setOffset, + setParserState, + ) +where + +import Control.Monad.Combinators +import Control.Monad.Identity +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as E +import Text.Megaparsec.Class import Text.Megaparsec.Error +import Text.Megaparsec.Internal import Text.Megaparsec.Pos -import Text.Megaparsec.Prim +import Text.Megaparsec.State +import Text.Megaparsec.Stream --- $assocbo +-- $reexports -- --- This combinator implements choice. The parser @p \<|> q@ first applies --- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails --- /without consuming any input/, parser @q@ is tried. +-- Note that we re-export monadic combinators from +-- "Control.Monad.Combinators" because these are more efficient than +-- 'Applicative'-based ones (†). Thus 'many' and 'some' may clash with the +-- functions from "Control.Applicative". You need to hide the functions like +-- this: -- --- The parser is called /predictive/ since @q@ is only tried when parser @p@ --- didn't consume any input (i.e. the look ahead is 1). This --- non-backtracking behaviour allows for both an efficient implementation of --- the parser combinators and the generation of good error messages. +-- > import Control.Applicative hiding (many, some) +-- +-- † As of Megaparsec 9.7.0 'Control.Applicative.many' and +-- 'Control.Applicative.some' are as efficient as their monadic +-- counterparts. +-- +-- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you +-- wish that combinators like 'some' return 'NonEmpty' lists. The module +-- lives in the @parser-combinators@ package (you need at least version +-- /0.4.0/). +-- +-- This module is intended to be imported qualified: +-- +-- > import qualified Control.Monad.Combinators.NonEmpty as NE +-- +-- Other modules of interest are: +-- +-- * "Control.Monad.Combinators.Expr" for parsing of expressions. +-- * "Control.Applicative.Permutations" for parsing of permutations +-- phrases. --- $many +---------------------------------------------------------------------------- +-- Data types + +-- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' +-- monad transformer. +type Parsec e s = ParsecT e s Identity + +---------------------------------------------------------------------------- +-- Running a parser + +-- | @'parse' p file input@ runs parser @p@ over 'Identity' (see +-- 'runParserT' if you're using the 'ParsecT' monad transformer; 'parse' +-- itself is just a synonym for 'runParser'). It returns either a +-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). +-- 'errorBundlePretty' can be used to turn 'ParseErrorBundle' into the +-- string representation of the error message. See "Text.Megaparsec.Error" +-- if you need to do more advanced error analysis. -- --- @many p@ applies the parser @p@ /zero/ or more times and returns a list --- of the returned values of @p@. Note that if the @p@ parser fails --- consuming input, then the entire @many p@ parser fails with the error --- message @p@ produced instead of just stopping iterating. In these cases --- wrapping @p@ with 'try' may be desirable. +-- > main = case parse numbers "" "11,2,43" of +-- > Left bundle -> putStr (errorBundlePretty bundle) +-- > Right xs -> print (sum xs) +-- > +-- > numbers = decimal `sepBy` char ',' -- --- > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_') +-- 'parse' is the same as 'runParser'. +parse :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a +parse = runParser --- $some +-- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the +-- result inside 'Just' on success and 'Nothing' on failure. This function +-- also parses 'eof', so if the parser doesn't consume all of its input, it +-- will fail. -- --- @some p@ applies the parser @p@ /one/ or more times and returns a list of --- the returned values of @p@. The note about behavior of the combinator in --- the case when @p@ fails consuming input (see 'A.many') applies to 'some' --- as well. +-- The function is supposed to be useful for lightweight parsing, where +-- error messages (and thus file names) are not important and entire input +-- should be consumed. For example, it can be used for parsing of a single +-- number according to a specification of its format. +parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a +parseMaybe p s = + case parse (p <* eof) "" s of + Left _ -> Nothing + Right x -> Just x + +-- | The expression @'parseTest' p input@ applies the parser @p@ on the +-- input @input@ and prints the result to stdout. Useful for testing. +parseTest :: + ( ShowErrorComponent e, + Show a, + VisualStream s, + TraversableStream s + ) => + -- | Parser to run + Parsec e s a -> + -- | Input for parser + s -> + IO () +parseTest p input = + case parse p "" input of + Left e -> putStr (errorBundlePretty e) + Right x -> print x + +-- | @'runParser' p file input@ runs parser @p@ on the input stream of +-- tokens @input@, obtained from source @file@. The @file@ is only used in +-- error messages and may be the empty string. Returns either a +-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). -- --- > word = some letter +-- > parseFromFile p file = runParser p file <$> readFile file +-- +-- 'runParser' is the same as 'parse'. +runParser :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a +runParser p name s = snd $ runParser' p (initialState name s) --- $optional +-- | The function is similar to 'runParser' with the difference that it +-- accepts and returns the parser state. This allows us e.g. to specify +-- arbitrary textual position at the beginning of parsing. This is the most +-- general way to run a parser over the 'Identity' monad. -- --- @optional p@ tries to apply the parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. On success result of --- @p@ is returned inside of 'Just', on failure 'Nothing' is returned. +-- @since 4.2.0 +runParser' :: + -- | Parser to run + Parsec e s a -> + -- | Initial state + State s e -> + (State s e, Either (ParseErrorBundle s e) a) +runParser' p = runIdentity . runParserT' p + +-- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens +-- @input@, obtained from source @file@. The @file@ is only used in error +-- messages and may be the empty string. Returns a computation in the +-- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or +-- a value of type @a@ ('Right'). +runParserT :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + m (Either (ParseErrorBundle s e) a) +runParserT p name s = snd <$> runParserT' p (initialState name s) + +-- | This function is similar to 'runParserT', but like 'runParser'' it +-- accepts and returns parser state. This is thus the most general way to +-- run a parser. +-- +-- @since 4.2.0 +runParserT' :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Initial state + State s e -> + m (State s e, Either (ParseErrorBundle s e) a) +runParserT' p s = do + (Reply s' _ result) <- runParsecT p s + let toBundle es = + ParseErrorBundle + { bundleErrors = + NE.sortWith errorOffset es, + bundlePosState = statePosState s + } + return $ case result of + OK _ x -> + case NE.nonEmpty (stateParseErrors s') of + Nothing -> (s', Right x) + Just de -> (s', Left (toBundle de)) + Error e -> + (s', Left (toBundle (e :| stateParseErrors s'))) + +---------------------------------------------------------------------------- +-- Signaling parse errors + +-- $parse-errors +-- +-- The most general function to fail and end parsing is 'parseError'. These +-- are built on top of it. The section also includes functions starting with +-- the @register@ prefix which allow users to register “delayed” +-- 'ParseError's. + +-- | Stop parsing and report a trivial 'ParseError'. +-- +-- @since 6.0.0 +failure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m a +failure us ps = do + o <- getOffset + parseError (TrivialError o us ps) +{-# INLINE failure #-} + +-- | Stop parsing and report a fancy 'ParseError'. To report a single custom +-- parse error, see 'Text.Megaparsec.customFailure'. +-- +-- @since 6.0.0 +fancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m a +fancyFailure xs = do + o <- getOffset + parseError (FancyError o xs) +{-# INLINE fancyFailure #-} + +-- | The parser @'unexpected' item@ fails with an error message telling +-- about unexpected item @item@ without consuming any input. +-- +-- > unexpected item = failure (Just item) Set.empty +unexpected :: (MonadParsec e s m) => ErrorItem (Token s) -> m a +unexpected item = failure (Just item) E.empty +{-# INLINE unexpected #-} + +-- | Report a custom parse error. For a more general version, see +-- 'fancyFailure'. +-- +-- > customFailure = fancyFailure . Set.singleton . ErrorCustom +-- +-- @since 6.3.0 +customFailure :: (MonadParsec e s m) => e -> m a +customFailure = fancyFailure . E.singleton . ErrorCustom +{-# INLINE customFailure #-} + +-- | Specify how to process 'ParseError's that happen inside of this +-- wrapper. This applies to both normal and delayed 'ParseError's. +-- +-- As a side-effect of the implementation the inner computation will start +-- with an empty collection of delayed errors and they will be updated and +-- “restored” on the way out of 'region'. +-- +-- @since 5.3.0 +region :: + (MonadParsec e s m) => + -- | How to process 'ParseError's + (ParseError s e -> ParseError s e) -> + -- | The “region” that the processing applies to + m a -> + m a +region f m = do + deSoFar <- stateParseErrors <$> getParserState + updateParserState $ \s -> + s {stateParseErrors = []} + r <- observing m + updateParserState $ \s -> + s {stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar} + case r of + Left err -> parseError (f err) + Right x -> return x +{-# INLINEABLE region #-} + +-- | Register a 'ParseError' for later reporting. This action does not end +-- parsing and has no effect except for adding the given 'ParseError' to the +-- collection of “delayed” 'ParseError's which will be taken into +-- consideration at the end of parsing. Only if this collection is empty will +-- the parser succeed. This is the main way to report several parse errors +-- at once. +-- +-- @since 8.0.0 +registerParseError :: (MonadParsec e s m) => ParseError s e -> m () +registerParseError e = updateParserState $ \s -> + s {stateParseErrors = e : stateParseErrors s} +{-# INLINE registerParseError #-} + +-- | Like 'failure', but for delayed 'ParseError's. +-- +-- @since 8.0.0 +registerFailure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m () +registerFailure us ps = do + o <- getOffset + registerParseError (TrivialError o us ps) +{-# INLINE registerFailure #-} + +-- | Like 'fancyFailure', but for delayed 'ParseError's. +-- +-- @since 8.0.0 +registerFancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m () +registerFancyFailure xs = do + o <- getOffset + registerParseError (FancyError o xs) +{-# INLINE registerFancyFailure #-} + +---------------------------------------------------------------------------- +-- Derivatives of primitive combinators + +-- | @'single' t@ only matches the single token @t@. +-- +-- > semicolon = single ';' +-- +-- See also: 'token', 'anySingle', 'Text.Megaparsec.Byte.char', +-- 'Text.Megaparsec.Char.char'. +-- +-- @since 7.0.0 +single :: + (MonadParsec e s m) => + -- | Token to match + Token s -> + m (Token s) +single t = token testToken expected + where + testToken x = if x == t then Just x else Nothing + expected = E.singleton (Tokens (t :| [])) +{-# INLINE single #-} + +-- | The parser @'satisfy' f@ succeeds for any token for which the supplied +-- function @f@ returns 'True'. +-- +-- > digitChar = satisfy isDigit "digit" +-- > oneOf cs = satisfy (`elem` cs) +-- +-- __Performance note__: when you need to parse a single token, it is often +-- a good idea to use 'satisfy' with the right predicate function instead of +-- creating a complex parser using the combinators. +-- +-- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'. +-- +-- @since 7.0.0 +satisfy :: + (MonadParsec e s m) => + -- | Predicate to apply + (Token s -> Bool) -> + m (Token s) +satisfy f = token testChar E.empty + where + testChar x = if f x then Just x else Nothing +{-# INLINE satisfy #-} + +-- | Parse and return a single token. It's a good idea to attach a 'label' +-- to this parser. +-- +-- > anySingle = satisfy (const True) +-- +-- See also: 'satisfy', 'anySingleBut'. +-- +-- @since 7.0.0 +anySingle :: (MonadParsec e s m) => m (Token s) +anySingle = satisfy (const True) +{-# INLINE anySingle #-} + +-- | Match any token but the given one. It's a good idea to attach a 'label' +-- to this parser. +-- +-- > anySingleBut t = satisfy (/= t) +-- +-- See also: 'single', 'anySingle', 'satisfy'. +-- +-- @since 7.0.0 +anySingleBut :: + (MonadParsec e s m) => + -- | Token we should not match + Token s -> + m (Token s) +anySingleBut t = satisfy (/= t) +{-# INLINE anySingleBut #-} + +-- | @'oneOf' ts@ succeeds if the current token is in the supplied +-- collection of tokens @ts@. Returns the parsed token. Note that this +-- parser cannot automatically generate the “expected” component of error +-- message, so usually you should label it manually with 'label' or (''). +-- +-- > oneOf cs = satisfy (`elem` cs) +-- +-- See also: 'satisfy'. +-- +-- > digit = oneOf ['0'..'9'] "digit" +-- +-- __Performance note__: prefer 'satisfy' when you can because it's faster +-- when you have only a couple of tokens to compare to: +-- +-- > quoteFast = satisfy (\x -> x == '\'' || x == '\"') +-- > quoteSlow = oneOf "'\"" +-- +-- @since 7.0.0 +oneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of matching tokens + f (Token s) -> + m (Token s) +oneOf cs = satisfy (\x -> elem x cs) +{-# INLINE oneOf #-} + +-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token is +-- /not/ in the supplied list of tokens @ts@. Returns the parsed character. +-- Note that this parser cannot automatically generate the “expected” +-- component of error message, so usually you should label it manually with +-- 'label' or (''). +-- +-- > noneOf cs = satisfy (`notElem` cs) +-- +-- See also: 'satisfy'. +-- +-- __Performance note__: prefer 'satisfy' and 'anySingleBut' when you can +-- because it's faster. +-- +-- @since 7.0.0 +noneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of tokens we should not match + f (Token s) -> + m (Token s) +noneOf cs = satisfy (\x -> notElem x cs) +{-# INLINE noneOf #-} + +-- | @'chunk' chk@ only matches the chunk @chk@. +-- +-- > divOrMod = chunk "div" <|> chunk "mod" +-- +-- See also: 'tokens', 'Text.Megaparsec.Char.string', +-- 'Text.Megaparsec.Byte.string'. +-- +-- @since 7.0.0 +chunk :: + (MonadParsec e s m) => + -- | Chunk to match + Tokens s -> + m (Tokens s) +chunk = tokens (==) +{-# INLINE chunk #-} + +-- | A synonym for 'label' in the form of an operator. +infix 0 + +() :: (MonadParsec e s m) => m a -> String -> m a +() = flip label +{-# INLINE () #-} + +-- | Return both the result of a parse and a chunk of input that was +-- consumed during parsing. This relies on the change of the 'stateOffset' +-- value to evaluate how many tokens were consumed. If you mess with it +-- manually in the argument parser, prepare for troubles. +-- +-- @since 5.3.0 +match :: (MonadParsec e s m) => m a -> m (Tokens s, a) +match p = do + o <- getOffset + s <- getInput + r <- p + o' <- getOffset + -- NOTE The 'fromJust' call here should never fail because if the stream + -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing' + -- as per its invariants), (tp' - tp) won't be greater than 0, and in that + -- case 'Just' is guaranteed to be returned as per another invariant of + -- 'takeN_'. + return ((fst . fromJust) (takeN_ (o' - o) s), r) +{-# INLINEABLE match #-} + +-- | Consume the rest of the input and return it as a chunk. This parser +-- never fails, but may return the empty chunk. +-- +-- > takeRest = takeWhileP Nothing (const True) +-- +-- @since 6.0.0 +takeRest :: (MonadParsec e s m) => m (Tokens s) +takeRest = takeWhileP Nothing (const True) +{-# INLINE takeRest #-} + +-- | Return 'True' when end of input has been reached. +-- +-- > atEnd = option False (True <$ hidden eof) +-- +-- @since 6.0.0 +atEnd :: (MonadParsec e s m) => m Bool +atEnd = option False (True <$ hidden eof) +{-# INLINE atEnd #-} + +---------------------------------------------------------------------------- +-- Parser state combinators + +-- | Return the current input. +getInput :: (MonadParsec e s m) => m s +getInput = stateInput <$> getParserState +{-# INLINE getInput #-} + +-- | @'setInput' input@ continues parsing with @input@. +setInput :: (MonadParsec e s m) => s -> m () +setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) +{-# INLINE setInput #-} + +-- | Return the current source position. This function /is not cheap/, do +-- not call it e.g. on matching of every token, that's a bad idea. Still you +-- can use it to get 'SourcePos' to attach to things that you parse. +-- +-- The function works under the assumption that we move in the input stream +-- only forwards and never backwards, which is always true unless the user +-- abuses the library. +-- +-- @since 7.0.0 +getSourcePos :: (TraversableStream s, MonadParsec e s m) => m SourcePos +getSourcePos = do + st <- getParserState + let pst = reachOffsetNoLine (stateOffset st) (statePosState st) + setParserState st {statePosState = pst} + return (pstateSourcePos pst) +{-# INLINE getSourcePos #-} + +-- | Get the number of tokens processed so far. +-- +-- See also: 'setOffset'. +-- +-- @since 7.0.0 +getOffset :: (MonadParsec e s m) => m Int +getOffset = stateOffset <$> getParserState +{-# INLINE getOffset #-} + +-- | Set the number of tokens processed so far. +-- +-- See also: 'getOffset'. +-- +-- @since 7.0.0 +setOffset :: (MonadParsec e s m) => Int -> m () +setOffset o = updateParserState $ \(State s _ pst de) -> + State s o pst de +{-# INLINE setOffset #-} + +-- | @'setParserState' st@ sets the parser state to @st@. +-- +-- See also: 'getParserState', 'updateParserState'. +setParserState :: (MonadParsec e s m) => State s e -> m () +setParserState st = updateParserState (const st) +{-# INLINE setParserState #-} diff --git a/Text/Megaparsec/Byte.hs b/Text/Megaparsec/Byte.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Byte.hs @@ -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 +-- 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 #-} diff --git a/Text/Megaparsec/Byte/Binary.hs b/Text/Megaparsec/Byte/Binary.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Byte/Binary.hs @@ -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 +-- 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 #-} diff --git a/Text/Megaparsec/Byte/Lexer.hs b/Text/Megaparsec/Byte/Lexer.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Byte/Lexer.hs @@ -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 +-- 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 #-} diff --git a/Text/Megaparsec/ByteString.hs b/Text/Megaparsec/ByteString.hs deleted file mode 100644 --- a/Text/Megaparsec/ByteString.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- Module : Text.Megaparsec.ByteString --- Copyright : © 2015–2017 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Convenience definitions for working with strict 'ByteString'. - -module Text.Megaparsec.ByteString (Parser) where - -import Data.ByteString -import Text.Megaparsec.Error (Dec) -import Text.Megaparsec.Prim - --- | Modules corresponding to various types of streams define 'Parser' --- accordingly, so the user can use it to easily change type of input stream --- by importing different “type modules”. This one is for strict --- 'ByteString's. - -type Parser = Parsec Dec ByteString diff --git a/Text/Megaparsec/ByteString/Lazy.hs b/Text/Megaparsec/ByteString/Lazy.hs deleted file mode 100644 --- a/Text/Megaparsec/ByteString/Lazy.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- Module : Text.Megaparsec.ByteString.Lazy --- Copyright : © 2015–2017 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Convenience definitions for working with lazy 'ByteString'. - -module Text.Megaparsec.ByteString.Lazy (Parser) where - -import Data.ByteString.Lazy -import Text.Megaparsec.Error (Dec) -import Text.Megaparsec.Prim - --- | Modules corresponding to various types of streams define 'Parser' --- accordingly, so the user can use it to easily change the type of input --- stream by importing different “type modules”. This one is for lazy --- 'ByteString's. - -type Parser = Parsec Dec ByteString diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs --- a/Text/Megaparsec/Char.hs +++ b/Text/Megaparsec/Char.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Char --- Copyright : © 2015–2017 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -10,141 +17,144 @@ -- Portability : non-portable -- -- Commonly used character parsers. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Char ( -- * Simple parsers - newline - , crlf - , eol - , tab - , space + newline, + crlf, + eol, + tab, + space, + hspace, + space1, + hspace1, + -- * Categories of characters - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , octDigitChar - , hexDigitChar - , markChar - , numberChar - , punctuationChar - , symbolChar - , separatorChar - , asciiChar - , latin1Char - , charCategory - , categoryName - -- * More general parsers - , char - , char' - , anyChar - , oneOf - , oneOf' - , noneOf - , noneOf' - , satisfy + controlChar, + spaceChar, + upperChar, + lowerChar, + letterChar, + alphaNumChar, + printChar, + digitChar, + binDigitChar, + octDigitChar, + hexDigitChar, + markChar, + numberChar, + punctuationChar, + symbolChar, + separatorChar, + asciiChar, + latin1Char, + charCategory, + categoryName, + + -- * Single character + char, + char', + -- * Sequence of characters - , string - , string' ) + string, + string', + ) where import Control.Applicative import Data.Char -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromJust) -import qualified Data.Set as E - -import Text.Megaparsec.Combinator -import Text.Megaparsec.Error -import Text.Megaparsec.Prim - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable (), any, elem, notElem) -import Prelude hiding (any, elem, notElem) -#endif +import Data.Functor (void) +import Data.Proxy +import Text.Megaparsec +import Text.Megaparsec.Common ---------------------------------------------------------------------------- -- Simple parsers -- | Parse a newline character. - -newline :: (MonadParsec e s m, Token s ~ Char) => m Char +newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. - -crlf :: (MonadParsec e s m, Token s ~ Char) => m String -crlf = string "\r\n" +crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) +crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. --- --- > eol = (pure <$> newline) <|> crlf "end of line" - -eol :: (MonadParsec e s m, Token s ~ Char) => m String -eol = (pure <$> newline) <|> crlf "end of line" +eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) +eol = + (tokenToChunk (Proxy :: Proxy s) <$> newline) + <|> crlf + "end of line" {-# INLINE eol #-} -- | Parse a tab character. - -tab :: (MonadParsec e s m, Token s ~ Char) => m Char +tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-} -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. - space :: (MonadParsec e s m, Token s ~ Char) => m () -space = skipMany spaceChar +space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace :: (MonadParsec e s m, Token s ~ Char) => m () +hspace = void $ takeWhileP (Just "white space") isHSpace +{-# INLINE hspace #-} + +-- | Skip /one/ or more white space characters. +-- +-- See also: 'skipSome' and 'spaceChar'. +-- +-- @since 6.0.0 +space1 :: (MonadParsec e s m, Token s ~ Char) => m () +space1 = void $ takeWhile1P (Just "white space") isSpace +{-# INLINE space1 #-} + +-- | Like 'space1', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace1 :: (MonadParsec e s m, Token s ~ Char) => m () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace +{-# INLINE hspace1 #-} + ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode). - -controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char +controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl "control character" {-# INLINE controlChar #-} -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. - -spaceChar :: (MonadParsec e s m, Token s ~ Char) => m Char +spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} -- | Parse an upper-case or title-case alphabetic Unicode character. Title -- case is used by a small number of letter ligatures like the -- single-character form of Lj. - -upperChar :: (MonadParsec e s m, Token s ~ Char) => m Char +upperChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) upperChar = satisfy isUpper "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic Unicode character. - -lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char +lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter. - -letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char +letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter "letter" {-# INLINE letterChar #-} @@ -153,143 +163,133 @@ -- Note that the numeric digits outside the ASCII range are parsed by this -- parser but not by 'digitChar'. Such digits may be part of identifiers but -- are not used by the printer and reader to represent numbers. - -alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m Char +alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) alphaNumChar = satisfy isAlphaNum "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space. - -printChar :: (MonadParsec e s m, Token s ~ Char) => m Char +printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. - -digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char +digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit "digit" {-# INLINE digitChar #-} --- | Parse an octal digit, i.e. between “0” and “7”. +-- | Parse a binary digit, i.e. "0" or "1". +-- +-- @since 7.0.0 +binDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) +binDigitChar = satisfy isBinDigit "binary digit" + where + isBinDigit x = x == '0' || x == '1' +{-# INLINE binDigitChar #-} -octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char +-- | Parse an octal digit, i.e. between “0” and “7”. +octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) octDigitChar = satisfy isOctDigit "octal digit" {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. - -hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char +hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters. - -markChar :: (MonadParsec e s m, Token s ~ Char) => m Char +markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark "mark character" {-# INLINE markChar #-} -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc. - -numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char +numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber "numeric character" {-# INLINE numberChar #-} -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes. - -punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m Char +punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) punctuationChar = satisfy isPunctuation "punctuation" {-# INLINE punctuationChar #-} -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols. - -symbolChar :: (MonadParsec e s m, Token s ~ Char) => m Char +symbolChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) symbolChar = satisfy isSymbol "symbol" {-# INLINE symbolChar #-} -- | Parse a Unicode space and separator characters. - -separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char +separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator "separator" {-# INLINE separatorChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. - -asciiChar :: (MonadParsec e s m, Token s ~ Char) => m Char +asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii "ASCII character" {-# INLINE asciiChar #-} -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. - -latin1Char :: (MonadParsec e s m, Token s ~ Char) => m Char +latin1Char :: (MonadParsec e s m, Token s ~ Char) => m (Token s) latin1Char = satisfy isLatin1 "Latin-1 character" {-# INLINE latin1Char #-} --- | @charCategory cat@ parses character in Unicode General Category @cat@, --- see 'Data.Char.GeneralCategory'. - -charCategory :: (MonadParsec e s m, Token s ~ Char) => GeneralCategory -> m Char +-- | @'charCategory' cat@ parses character in Unicode General Category +-- @cat@, see 'Data.Char.GeneralCategory'. +charCategory :: + (MonadParsec e s m, Token s ~ Char) => + GeneralCategory -> + m (Token s) charCategory cat = satisfy ((== cat) . generalCategory) categoryName cat {-# INLINE charCategory #-} -- | Return the human-readable name of Unicode General Category. - categoryName :: GeneralCategory -> String -categoryName cat = - fromJust $ lookup cat - [ (UppercaseLetter , "uppercase letter") - , (LowercaseLetter , "lowercase letter") - , (TitlecaseLetter , "titlecase letter") - , (ModifierLetter , "modifier letter") - , (OtherLetter , "other letter") - , (NonSpacingMark , "non-spacing mark") - , (SpacingCombiningMark, "spacing combining mark") - , (EnclosingMark , "enclosing mark") - , (DecimalNumber , "decimal number character") - , (LetterNumber , "letter number character") - , (OtherNumber , "other number character") - , (ConnectorPunctuation, "connector punctuation") - , (DashPunctuation , "dash punctuation") - , (OpenPunctuation , "open punctuation") - , (ClosePunctuation , "close punctuation") - , (InitialQuote , "initial quote") - , (FinalQuote , "final quote") - , (OtherPunctuation , "other punctuation") - , (MathSymbol , "math symbol") - , (CurrencySymbol , "currency symbol") - , (ModifierSymbol , "modifier symbol") - , (OtherSymbol , "other symbol") - , (Space , "white space") - , (LineSeparator , "line separator") - , (ParagraphSeparator , "paragraph separator") - , (Control , "control character") - , (Format , "format character") - , (Surrogate , "surrogate character") - , (PrivateUse , "private-use Unicode character") - , (NotAssigned , "non-assigned Unicode character") ] +categoryName = \case + UppercaseLetter -> "uppercase letter" + LowercaseLetter -> "lowercase letter" + TitlecaseLetter -> "titlecase letter" + ModifierLetter -> "modifier letter" + OtherLetter -> "other letter" + NonSpacingMark -> "non-spacing mark" + SpacingCombiningMark -> "spacing combining mark" + EnclosingMark -> "enclosing mark" + DecimalNumber -> "decimal number character" + LetterNumber -> "letter number character" + OtherNumber -> "other number character" + ConnectorPunctuation -> "connector punctuation" + DashPunctuation -> "dash punctuation" + OpenPunctuation -> "open punctuation" + ClosePunctuation -> "close punctuation" + InitialQuote -> "initial quote" + FinalQuote -> "final quote" + OtherPunctuation -> "other punctuation" + MathSymbol -> "math symbol" + CurrencySymbol -> "currency symbol" + ModifierSymbol -> "modifier symbol" + OtherSymbol -> "other symbol" + Space -> "white space" + LineSeparator -> "line separator" + ParagraphSeparator -> "paragraph separator" + Control -> "control character" + Format -> "format character" + Surrogate -> "surrogate character" + PrivateUse -> "private-use Unicode character" + NotAssigned -> "non-assigned Unicode character" ---------------------------------------------------------------------------- --- More general parsers +-- Single character --- | @char c@ parses a single character @c@. +-- | A type-constrained version of 'single'. -- -- > semicolon = char ';' - -char :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char -char c = token testChar (Just c) - where - f x = E.singleton (Tokens (x:|[])) - testChar x = - if x == c - then Right x - else Left (f x, f c, E.empty) +char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) +char = single {-# INLINE char #-} -- | The same as 'char' but case-insensitive. This parser returns the @@ -301,116 +301,18 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' - -char' :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char -char' c = choice [char c, char $ swapCase c] - where - swapCase x - | isUpper x = toLower x - | isLower x = toUpper x - | otherwise = x +char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) +char' c = + choice + [ char (toLower c), + char (toUpper c), + char (toTitle c) + ] {-# INLINE char' #-} --- | This parser succeeds for any character. Returns the parsed character. - -anyChar :: (MonadParsec e s m, Token s ~ Char) => m Char -anyChar = satisfy (const True) "character" -{-# INLINE anyChar #-} - --- | @oneOf cs@ succeeds if the current character is in the supplied --- collection of characters @cs@. Returns the parsed character. Note that --- this parser cannot automatically generate the “expected” component of --- error message, so usually you should label it manually with 'label' or --- (''). --- --- See also: 'satisfy'. --- --- > digit = oneOf ['0'..'9'] "digit" - -oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char -oneOf cs = satisfy (`elem` cs) -{-# INLINE oneOf #-} - --- | The same as 'oneOf', but case-insensitive. Returns the parsed character --- preserving its case. --- --- > vowel = oneOf' "aeiou" "vowel" - -oneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char -oneOf' cs = satisfy (`elemi` cs) -{-# INLINE oneOf' #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current character --- /not/ in the supplied list of characters @cs@. Returns the parsed --- character. - -noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char -noneOf cs = satisfy (`notElem` cs) -{-# INLINE noneOf #-} - --- | The same as 'noneOf', but case-insensitive. --- --- > consonant = noneOf' "aeiou" "consonant" - -noneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char -noneOf' cs = satisfy (`notElemi` cs) -{-# INLINE noneOf' #-} - --- | The parser @satisfy f@ succeeds for any character for which the --- supplied function @f@ returns 'True'. Returns the character that is --- actually parsed. --- --- > digitChar = satisfy isDigit "digit" --- > oneOf cs = satisfy (`elem` cs) - -satisfy :: (MonadParsec e s m, Token s ~ Char) => (Char -> Bool) -> m Char -satisfy f = token testChar Nothing - where - testChar x = - if f x - then Right x - else Left (E.singleton (Tokens (x:|[])), E.empty, E.empty) -{-# INLINE satisfy #-} - ---------------------------------------------------------------------------- --- Sequence of characters - --- | @string s@ parses a sequence of characters given by @s@. Returns the --- parsed string (i.e. @s@). --- --- > divOrMod = string "div" <|> string "mod" - -string :: (MonadParsec e s m, Token s ~ Char) => String -> m String -string = tokens (==) -{-# INLINE string #-} - --- | The same as 'string', but case-insensitive. On success returns string --- cased as actually parsed input. --- --- >>> parseTest (string' "foobar") "foObAr" --- "foObAr" - -string' :: (MonadParsec e s m, Token s ~ Char) => String -> m String -string' = tokens casei -{-# INLINE string' #-} - ----------------------------------------------------------------------------- -- Helpers --- | Case-insensitive equality test for characters. - -casei :: Char -> Char -> Bool -casei x y = toUpper x == toUpper y -{-# INLINE casei #-} - --- | Case-insensitive 'elem'. - -elemi :: Foldable f => Char -> f Char -> Bool -elemi = any . casei -{-# INLINE elemi #-} - --- | Case-insensitive 'notElem'. - -notElemi :: Foldable f => Char -> f Char -> Bool -notElemi c = not . elemi c -{-# INLINE notElemi #-} +-- | Is it a horizontal space character? +isHSpace :: Char -> Bool +isHSpace x = isSpace x && x /= '\n' && x /= '\r' diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Char/Lexer.hs @@ -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 +-- 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 #-} diff --git a/Text/Megaparsec/Class.hs b/Text/Megaparsec/Class.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Class.hs @@ -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 +-- 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' #-} diff --git a/Text/Megaparsec/Combinator.hs b/Text/Megaparsec/Combinator.hs deleted file mode 100644 --- a/Text/Megaparsec/Combinator.hs +++ /dev/null @@ -1,181 +0,0 @@ --- | --- Module : Text.Megaparsec.Combinator --- Copyright : © 2015–2017 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Commonly used generic combinators. Note that all the combinators work --- with 'Applicative' and 'Alternative' instances. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} - -module Text.Megaparsec.Combinator - ( between - , choice - , count - , count' - , eitherP - , endBy - , endBy1 - , manyTill - , someTill - , option - , sepBy - , sepBy1 - , sepEndBy - , sepEndBy1 - , skipMany - , skipSome ) -where - -import Control.Applicative -import Control.Monad (void) -import Data.Foldable (asum) - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable) -import Data.Traversable (sequenceA) -#endif - --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") - -between :: Applicative m => m open -> m close -> m a -> m a -between open close p = open *> p <* close -{-# INLINE between #-} - --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, until --- one of them succeeds. Returns the value of the succeeding parser. - -choice :: (Foldable f, Alternative m) => f (m a) -> m a -choice = asum -{-# INLINE choice #-} - --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal --- to zero, the parser equals to @return []@. Returns a list of @n@ values. - -count :: Applicative m => Int -> m a -> m [a] -count n p = sequenceA (replicate n p) -{-# INLINE count #-} - --- | @count' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is not --- positive or @m > n@, the parser equals to @return []@. Returns a list of --- parsed values. --- --- Please note that @m@ /may/ be negative, in this case effect is the same --- as if it were equal to zero. - -count' :: Alternative m => Int -> Int -> m a -> m [a] -count' m' n' p = go m' n' - where - go !m !n - | n <= 0 || m > n = pure [] - | m > 0 = (:) <$> p <*> go (m - 1) (n - 1) - | otherwise = - let f t ts = maybe [] (:ts) t - in f <$> optional p <*> go 0 (pred n) -{-# INLINE count' #-} - --- | Combine two alternatives. --- --- @since 4.4.0 - -eitherP :: Alternative m => m a -> m b -> m (Either a b) -eitherP a b = (Left <$> a) <|> (Right <$> b) -{-# INLINE eitherP #-} - --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated and --- ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semicolon - -endBy :: Alternative m => m a -> m sep -> m [a] -endBy p sep = many (p <* sep) -{-# INLINE endBy #-} - --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated and --- ended by @sep@. Returns a list of values returned by @p@. - -endBy1 :: Alternative m => m a -> m sep -> m [a] -endBy1 p sep = some (p <* sep) -{-# INLINE endBy1 #-} - --- | @manyTill p end@ applies parser @p@ /zero/ or more times until parser --- @end@ succeeds. Returns the list of values returned by @p@. This parser --- can be used to scan comments: --- --- > simpleComment = string "") - -manyTill :: Alternative m => m a -> m end -> m [a] -manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) -{-# INLINE manyTill #-} - --- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should --- succeed at least once. - -someTill :: Alternative m => m a -> m end -> m [a] -someTill p end = (:) <$> p <*> manyTill p end -{-# INLINE someTill #-} - --- | @option x p@ tries to apply the parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value returned --- by @p@. --- --- > priority = option 0 (digitToInt <$> digitChar) - -option :: Alternative m => a -> m a -> m a -option x p = p <|> pure x -{-# INLINE option #-} - --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated by --- @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` comma - -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = sepBy1 p sep <|> pure [] -{-# INLINE sepBy #-} - --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated by --- @sep@. Returns a list of values returned by @p@. - -sepBy1 :: Alternative m => m a -> m sep -> m [a] -sepBy1 p sep = (:) <$> p <*> many (sep *> p) -{-# INLINE sepBy1 #-} - --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, separated --- and optionally ended by @sep@. Returns a list of values returned by @p@. - -sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = sepEndBy1 p sep <|> pure [] -{-# INLINE sepEndBy #-} - --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- and optionally ended by @sep@. Returns a list of values returned by @p@. - -sepEndBy1 :: Alternative m => m a -> m sep -> m [a] -sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) - --- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping its --- result. --- --- > space = skipMany spaceChar - -skipMany :: Alternative m => m a -> m () -skipMany p = void $ many p -{-# INLINE skipMany #-} - --- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping its --- result. - -skipSome :: Alternative m => m a -> m () -skipSome p = void $ some p -{-# INLINE skipSome #-} diff --git a/Text/Megaparsec/Common.hs b/Text/Megaparsec/Common.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Common.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + +-- | +-- Module : Text.Megaparsec.Common +-- Copyright : © 2018–present Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- 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' #-} diff --git a/Text/Megaparsec/Debug.hs b/Text/Megaparsec/Debug.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Debug.hs @@ -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 +-- 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 -> "" + 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" diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -1,360 +1,576 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Error --- Copyright : © 2015–2017 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- --- Parse errors. Current version of Megaparsec supports well-typed errors +-- Parse errors. The current version of Megaparsec supports typed errors -- instead of 'String'-based ones. This gives a lot of flexibility in -- describing what exactly went wrong as well as a way to return arbitrary -- data in case of failure. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - +-- +-- You probably do not want to import this module directly because +-- "Text.Megaparsec" re-exports it anyway. module Text.Megaparsec.Error - ( ErrorItem (..) - , ErrorComponent (..) - , Dec (..) - , ParseError (..) - , ShowToken (..) - , ShowErrorComponent (..) - , parseErrorPretty - , sourcePosStackPretty - , parseErrorTextPretty ) + ( -- * Parse error type + ErrorItem (..), + ErrorFancy (..), + ParseError (..), + mapParseError, + errorOffset, + setErrorOffset, + ParseErrorBundle (..), + attachSourcePos, + + -- * Pretty-printing + ShowErrorComponent (..), + errorBundlePretty, + errorBundlePrettyForGhcPreProcessors, + errorBundlePrettyWith, + parseErrorPretty, + parseErrorTextPretty, + showErrorItem, + ) where +import Control.Arrow ((>>>)) import Control.DeepSeq -import Control.Monad.Catch +import Control.Exception +import Control.Monad.State.Strict import Data.Data (Data) -import Data.Foldable (concat) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isNothing) +import Data.Proxy import Data.Set (Set) +import qualified Data.Set as E import Data.Typeable (Typeable) +import Data.Void import GHC.Generics -import Prelude hiding (concat) -import Test.QuickCheck hiding (label) -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E - import Text.Megaparsec.Pos +import Text.Megaparsec.State +import Text.Megaparsec.Stream +import qualified Text.Megaparsec.Unicode as Unicode -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +---------------------------------------------------------------------------- +-- Parse error type --- | Data type that is used to represent “unexpected\/expected” items in --- 'ParseError'. The data type is parametrized over the token type @t@. +-- | A data type that is used to represent “unexpected\/expected” items in +-- 'ParseError'. It is parametrized over the token type @t@. -- -- @since 5.0.0 - data ErrorItem t - = Tokens (NonEmpty t) -- ^ Non-empty stream of tokens - | Label (NonEmpty Char) -- ^ Label (cannot be empty) - | EndOfInput -- ^ End of input - deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) - -instance NFData t => NFData (ErrorItem t) - -instance Arbitrary t => Arbitrary (ErrorItem t) where - arbitrary = oneof - [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary) - , Label <$> (NE.fromList . getNonEmpty <$> arbitrary) - , return EndOfInput ] - --- | The type class defines how to represent information about various --- exceptional situations. Data types that are used as custom data component --- in 'ParseError' must be instances of this type class. --- --- @since 5.0.0 - -class Ord e => ErrorComponent e where - - -- | Represent the message passed to 'fail' in parser monad. - -- - -- @since 5.0.0 - - representFail :: String -> e - - -- | Represent information about incorrect indentation. - -- - -- @since 5.0.0 - - representIndentation - :: Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> Pos -- ^ Actual indentation level - -> e + = -- | Non-empty stream of tokens + Tokens (NonEmpty t) + | -- | Label (cannot be empty) + Label (NonEmpty Char) + | -- | End of input + EndOfInput + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance ErrorComponent () where - representFail _ = () - representIndentation _ _ _ = () +instance (NFData t) => NFData (ErrorItem t) --- | “Default error component”. This is our instance of 'ErrorComponent' --- provided out-of-box. +-- | Additional error data, extendable by user. When no custom data is +-- necessary, the type is typically indexed by 'Void' to “cancel” the +-- 'ErrorCustom' constructor. -- --- @since 5.0.0 - -data Dec - = DecFail String -- ^ 'fail' has been used in parser monad - | DecIndentation Ordering Pos Pos - -- ^ Incorrect indentation error: desired ordering between reference +-- @since 6.0.0 +data ErrorFancy e + = -- | 'fail' has been used in parser monad + ErrorFail String + | -- | Incorrect indentation error: desired ordering between reference -- level and actual level, reference indentation level, actual -- indentation level - deriving (Show, Read, Eq, Ord, Data, Typeable) - -instance NFData Dec where - rnf (DecFail str) = rnf str - rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act - -instance Arbitrary Dec where - arbitrary = oneof - [ sized (\n -> do - k <- choose (0, n `div` 2) - DecFail <$> vectorOf k arbitrary) - , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] + ErrorIndentation Ordering Pos Pos + | -- | Custom error data + ErrorCustom e + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance ErrorComponent Dec where - representFail = DecFail - representIndentation = DecIndentation +instance (NFData a) => NFData (ErrorFancy a) where + rnf (ErrorFail str) = rnf str + rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act + rnf (ErrorCustom a) = rnf a --- | 'ParseError' represents… parse errors. It provides the stack of source --- positions, a set of expected and unexpected tokens as well as a set of --- custom associated data. The data type is parametrized over the token type --- @t@ and the custom data @e@. --- --- Note that the stack of source positions contains current position as its --- head, and the rest of positions allows to track full sequence of include --- files with topmost source file at the end of the list. +-- | @'ParseError' s e@ represents a parse error parametrized over the +-- stream type @s@ and the custom data @e@. -- --- 'Semigroup' (and 'Monoid') instance of the data type allows to merge +-- 'Semigroup' and 'Monoid' instances of the data type allow us to merge -- parse errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same, --- custom data sets and collections of message items are combined. +-- custom data sets and collections of message items are combined. Note that +-- fancy errors take precedence over trivial errors in merging. +-- +-- @since 7.0.0 +data ParseError s e + = -- | Trivial errors, generated by the Megaparsec's machinery. The data + -- constructor includes the offset of error, unexpected token (if any), + -- and expected tokens. + -- + -- Type of the first argument was changed in the version /7.0.0/. + TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) + | -- | Fancy, custom errors. + -- + -- Type of the first argument was changed in the version /7.0.0/. + FancyError Int (Set (ErrorFancy e)) + deriving (Generic) -data ParseError t e = ParseError - { errorPos :: NonEmpty SourcePos -- ^ Stack of source positions - , errorUnexpected :: Set (ErrorItem t) -- ^ Unexpected items - , errorExpected :: Set (ErrorItem t) -- ^ Expected items - , errorCustom :: Set e -- ^ Associated data, if any - } deriving (Show, Read, Eq, Data, Typeable, Generic) +deriving instance + ( Show (Token s), + Show e + ) => + Show (ParseError s e) -instance (NFData t, NFData e) => NFData (ParseError t e) +deriving instance + ( Eq (Token s), + Eq e + ) => + Eq (ParseError s e) -instance (Ord t, Ord e) => Semigroup (ParseError t e) where +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseError s e) + +instance + ( NFData (Token s), + NFData e + ) => + NFData (ParseError s e) + +instance (Stream s, Ord e) => Semigroup (ParseError s e) where (<>) = mergeError {-# INLINE (<>) #-} -instance (Ord t, Ord e) => Monoid (ParseError t e) where - mempty = ParseError (initialPos "" :| []) E.empty E.empty E.empty +instance (Stream s, Ord e) => Monoid (ParseError s e) where + mempty = TrivialError 0 Nothing E.empty mappend = (<>) {-# INLINE mappend #-} -instance ( Show t - , Typeable t - , Ord t - , ShowToken t - , Show e - , Typeable e - , ShowErrorComponent e ) - => Exception (ParseError t e) where -#if MIN_VERSION_base(4,8,0) +instance + ( Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + Typeable s, + Typeable e + ) => + Exception (ParseError s e) + where displayException = parseErrorPretty -#endif -instance (Arbitrary t, Ord t, Arbitrary e, Ord e) - => Arbitrary (ParseError t e) where - arbitrary = ParseError - <$> (NE.fromList . getNonEmpty <$> arbitrary) -#if MIN_VERSION_QuickCheck(2,8,2) - <*> arbitrary - <*> arbitrary - <*> arbitrary -#else - <*> (E.fromList <$> arbitrary) - <*> (E.fromList <$> arbitrary) - <*> (E.fromList <$> arbitrary) -#endif +-- | Modify the custom data component in a parse error. This could be done +-- via 'fmap' if not for the 'Ord' constraint. +-- +-- @since 7.0.0 +mapParseError :: + (Ord e') => + (e -> e') -> + ParseError s e -> + ParseError s e' +mapParseError _ (TrivialError o u p) = TrivialError o u p +mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) +-- | Get the offset of a 'ParseError'. +-- +-- @since 7.0.0 +errorOffset :: ParseError s e -> Int +errorOffset (TrivialError o _ _) = o +errorOffset (FancyError o _) = o + +-- | Set the offset of a 'ParseError'. +-- +-- @since 8.0.0 +setErrorOffset :: Int -> ParseError s e -> ParseError s e +setErrorOffset o (TrivialError _ u p) = TrivialError o u p +setErrorOffset o (FancyError _ x) = FancyError o x + -- | Merge two error data structures into one joining their collections of -- message items and preferring the longest match. In other words, earlier -- error message is discarded. This may seem counter-intuitive, but -- 'mergeError' is only used to merge error messages of alternative branches -- of parsing and in this case longest match should be preferred. - -mergeError :: (Ord t, Ord e) - => ParseError t e - -> ParseError t e - -> ParseError t e -mergeError e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) = - case pos1 `compare` pos2 of +mergeError :: + (Stream s, Ord e) => + ParseError s e -> + ParseError s e -> + ParseError s e +mergeError e1 e2 = + case errorOffset e1 `compare` errorOffset e2 of LT -> e2 - EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2) + EQ -> + case (e1, e2) of + (TrivialError s1 u1 p1, TrivialError _ u2 p2) -> + TrivialError s1 (n u1 u2) (E.union p1 p2) + (FancyError {}, TrivialError {}) -> e1 + (TrivialError {}, FancyError {}) -> e2 + (FancyError s1 x1, FancyError _ x2) -> + FancyError s1 (E.union x1 x2) GT -> e1 + where + -- NOTE The logic behind this merging is that since we only combine + -- parse errors that happen at exactly the same position, all the + -- unexpected items will be prefixes of input stream at that position or + -- labels referring to the same thing. Our aim here is to choose the + -- longest prefix (merging with labels and end of input is somewhat + -- arbitrary, but is necessary because otherwise we can't make + -- ParseError lawful Monoid and have nice parse errors at the same + -- time). + n Nothing Nothing = Nothing + n (Just x) Nothing = Just x + n Nothing (Just y) = Just y + n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} --- | Type class 'ShowToken' includes methods that allow to pretty-print --- single token as well as stream of tokens. This is used for rendering of --- error messages. - -class ShowToken a where +-- | A non-empty collection of 'ParseError's equipped with 'PosState' that +-- allows us to pretty-print the errors efficiently and correctly. +-- +-- @since 7.0.0 +data ParseErrorBundle s e = ParseErrorBundle + { -- | A collection of 'ParseError's that is sorted by parse error offsets + bundleErrors :: NonEmpty (ParseError s e), + -- | The state that is used for line\/column calculation + bundlePosState :: PosState s + } + deriving (Generic) - -- | Pretty-print non-empty stream of tokens. This function is also used - -- to print single tokens (represented as singleton lists). - -- - -- @since 5.0.0 +deriving instance + ( Show s, + Show (Token s), + Show e + ) => + Show (ParseErrorBundle s e) - showTokens :: NonEmpty a -> String +deriving instance + ( Eq s, + Eq (Token s), + Eq e + ) => + Eq (ParseErrorBundle s e) -instance ShowToken Char where - showTokens = stringPretty +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseErrorBundle s e) --- | @stringPretty s@ returns pretty representation of string @s@. This is --- used when printing string tokens in error messages. +instance + ( NFData s, + NFData (Token s), + NFData e + ) => + NFData (ParseErrorBundle s e) -stringPretty :: NonEmpty Char -> String -stringPretty (x:|[]) = charPretty x -stringPretty ('\r':|"\n") = "crlf newline" -stringPretty xs = "\"" ++ NE.toList xs ++ "\"" +instance + ( Show s, + Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + TraversableStream s, + Typeable s, + Typeable e + ) => + Exception (ParseErrorBundle s e) + where + displayException = errorBundlePretty --- | @charPretty ch@ returns user-friendly string representation of given --- character @ch@, suitable for using in error messages. +-- | Attach 'SourcePos'es to items in a 'Traversable' container given that +-- there is a projection allowing us to get an offset per item. +-- +-- Items must be in ascending order with respect to their offsets. +-- +-- @since 7.0.0 +attachSourcePos :: + (Traversable t, TraversableStream s) => + -- | How to project offset from an item (e.g. 'errorOffset') + (a -> Int) -> + -- | The collection of items + t a -> + -- | Initial 'PosState' + PosState s -> + -- | The collection with 'SourcePos'es added and the final 'PosState' + (t (a, SourcePos), PosState s) +attachSourcePos projectOffset xs = runState (traverse f xs) + where + f a = do + pst <- get + let pst' = reachOffsetNoLine (projectOffset a) pst + put pst' + return (a, pstateSourcePos pst') +{-# INLINEABLE attachSourcePos #-} -charPretty :: Char -> String -charPretty '\NUL' = "null (control character)" -charPretty '\SOH' = "start of heading (control character)" -charPretty '\STX' = "start of text (control character)" -charPretty '\ETX' = "end of text (control character)" -charPretty '\EOT' = "end of transmission (control character)" -charPretty '\ENQ' = "enquiry (control character)" -charPretty '\ACK' = "acknowledge (control character)" -charPretty '\BEL' = "bell (control character)" -charPretty '\BS' = "backspace" -charPretty '\t' = "tab" -charPretty '\n' = "newline" -charPretty '\v' = "vertical tab" -charPretty '\f' = "form feed (control character)" -charPretty '\r' = "carriage return" -charPretty '\SO' = "shift out (control character)" -charPretty '\SI' = "shift in (control character)" -charPretty '\DLE' = "data link escape (control character)" -charPretty '\DC1' = "device control one (control character)" -charPretty '\DC2' = "device control two (control character)" -charPretty '\DC3' = "device control three (control character)" -charPretty '\DC4' = "device control four (control character)" -charPretty '\NAK' = "negative acknowledge (control character)" -charPretty '\SYN' = "synchronous idle (control character)" -charPretty '\ETB' = "end of transmission block (control character)" -charPretty '\CAN' = "cancel (control character)" -charPretty '\EM' = "end of medium (control character)" -charPretty '\SUB' = "substitute (control character)" -charPretty '\ESC' = "escape (control character)" -charPretty '\FS' = "file separator (control character)" -charPretty '\GS' = "group separator (control character)" -charPretty '\RS' = "record separator (control character)" -charPretty '\US' = "unit separator (control character)" -charPretty '\DEL' = "delete (control character)" -charPretty ' ' = "space" -charPretty '\160' = "non-breaking space" -charPretty x = "'" ++ [x] ++ "'" +---------------------------------------------------------------------------- +-- Pretty-printing --- | The type class defines how to print custom data component of --- 'ParseError'. +-- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0 +class (Ord a) => ShowErrorComponent a where + -- | Pretty-print a component of 'ParseError'. + showErrorComponent :: a -> String -class Ord a => ShowErrorComponent a where + -- | Length of the error component in characters, used for highlighting of + -- parse errors in input string. + -- + -- @since 7.0.0 + errorComponentLen :: a -> Int + errorComponentLen _ = 1 - -- | Pretty-print custom data component of 'ParseError'. +instance ShowErrorComponent Void where + showErrorComponent = absurd - showErrorComponent :: a -> String +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order, by applying a provided format function, with +-- a single pass over the input stream. +-- +-- @since 9.7.0 +errorBundlePrettyWith :: + forall s e. + ( VisualStream s, + TraversableStream s + ) => + -- | Format function for a single 'ParseError' + (Maybe String -> SourcePos -> ParseError s e -> String) -> + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyWith format ParseErrorBundle {..} = + let (r, _) = foldl f (id, bundlePosState) bundleErrors + in r "" + where + f :: + (ShowS, PosState s) -> + ParseError s e -> + (ShowS, PosState s) + f (o, !pst) e = (o . (outChunk ++), pst') + where + (msline, pst') = reachOffset (errorOffset e) pst + epos = pstateSourcePos pst' + outChunk = format msline epos e -instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where - showErrorComponent (Tokens ts) = showTokens ts - showErrorComponent (Label label) = NE.toList label - showErrorComponent EndOfInput = "end of input" +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order together with the corresponding offending +-- lines by doing a single pass over the input stream. The rendered 'String' +-- always ends with a newline. +-- +-- @since 7.0.0 +errorBundlePretty :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePretty = drop 1 . errorBundlePrettyWith format + where + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format msline epos e = outChunk + where + outChunk = + "\n" + <> sourcePosPretty epos + <> ":\n" + <> offendingLine + <> parseErrorTextPretty e + offendingLine = + case msline of + Nothing -> "" + Just sline -> + let rpadding = + if pointerLen > 0 + then replicate rpshift ' ' + else "" + pointerLen = + if rpshift + elen > slineLen + then slineLen - rpshift + 1 + else max 1 elen + pointer = replicate pointerLen '^' + lineNumber = (show . unPos . sourceLine) epos + padding = replicate (length lineNumber + 1) ' ' + rpshift = unPos (sourceColumn epos) - 1 + slineLen = Unicode.stringLength sline + in padding + <> "|\n" + <> lineNumber + <> " | " + <> sline + <> "\n" + <> padding + <> "| " + <> rpadding + <> pointer + <> "\n" + pxy = Proxy :: Proxy s + elen = + case e of + TrivialError _ Nothing _ -> 1 + TrivialError _ (Just x) _ -> errorItemLength pxy x + FancyError _ xs -> + E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs -instance ShowErrorComponent Dec where - showErrorComponent (DecFail msg) = msg - showErrorComponent (DecIndentation ord ref actual) = - "incorrect indentation (got " ++ show (unPos actual) ++ - ", should be " ++ p ++ show (unPos ref) ++ ")" - where p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order by doing a single pass over the input stream. +-- +-- The rendered format is suitable for custom GHC pre-processors (as can be +-- specified with -F -pgmF). +-- +-- @since 9.7.0 +errorBundlePrettyForGhcPreProcessors :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format + where + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format _msline epos e = + sourcePosPretty epos + <> ":" + <> indent (parseErrorTextPretty e) + indent :: String -> String + indent = + lines >>> \case + [err] -> err + err -> intercalate "\n" $ map (" " <>) err + -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. -- --- The function is defined as: --- --- > parseErrorPretty e = --- > sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e --- -- @since 5.0.0 - -parseErrorPretty :: ( Ord t - , ShowToken t - , ShowErrorComponent e ) - => ParseError t e -- ^ Parse error to render - -> String -- ^ Result of rendering +parseErrorPretty :: + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String parseErrorPretty e = - sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e + "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e --- | Pretty-print a stack of source positions. +-- | Pretty-print a textual part of a 'ParseError', that is, everything +-- except for its position. The rendered 'String' always ends with a +-- newline. -- --- @since 5.0.0 +-- @since 5.1.0 +parseErrorTextPretty :: + forall s e. + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String +parseErrorTextPretty (TrivialError _ us ps) = + if isNothing us && E.null ps + then "unknown parse error\n" + else + messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) + <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps) + where + pxy = Proxy :: Proxy s +parseErrorTextPretty (FancyError _ xs) = + if E.null xs + then "unknown fancy parse error\n" + else unlines (showErrorFancy <$> E.toAscList xs) -sourcePosStackPretty :: NonEmpty SourcePos -> String -sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos - where (pos :| rest') = ms - rest = reverse rest' - f p = "in file included from " ++ sourcePosPretty p ++ ",\n" +---------------------------------------------------------------------------- +-- Helpers --- | Transforms a list of error messages into their textual representation. +-- | Pretty-print an 'ErrorItem'. +-- +-- @since 9.4.0 +showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String +showErrorItem pxy = \case + Tokens ts -> showTokens pxy ts + Label label -> NE.toList label + EndOfInput -> "end of input" -messageItemsPretty :: ShowErrorComponent a - => String -- ^ Prefix to prepend - -> Set a -- ^ Collection of messages - -> String -- ^ Result of rendering +-- | Get length of the “pointer” to display under a given 'ErrorItem'. +errorItemLength :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> Int +errorItemLength pxy = \case + Tokens ts -> tokensLength pxy ts + _ -> 1 + +-- | Pretty-print an 'ErrorFancy'. +showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String +showErrorFancy = \case + ErrorFail msg -> msg + ErrorIndentation ord ref actual -> + "incorrect indentation (got " + <> show (unPos actual) + <> ", should be " + <> p + <> show (unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " + ErrorCustom a -> showErrorComponent a + +-- | Get length of the “pointer” to display under a given 'ErrorFancy'. +errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int +errorFancyLength = \case + ErrorCustom a -> errorComponentLen a + _ -> 1 + +-- | Transform a list of error messages into their textual representation. +messageItemsPretty :: + -- | Prefix to prepend + String -> + -- | Collection of messages + Set String -> + -- | Result of rendering + String messageItemsPretty prefix ts | E.null ts = "" | otherwise = - let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent - in prefix ++ f ts ++ "\n" + prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n" -- | Print a pretty list where items are separated with commas and the word -- “or” according to the rules of English punctuation. - orList :: NonEmpty String -> String -orList (x:|[]) = x -orList (x:|[y]) = x ++ " or " ++ y -orList xs = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs - --- | Pretty-print a textual part of a 'ParseError', that is, everything --- except stack of source positions. The rendered staring always ends with a --- new line. --- --- @since 5.1.0 - -parseErrorTextPretty :: ( Ord t - , ShowToken t - , ShowErrorComponent e ) - => ParseError t e -- ^ Parse error to render - -> String -- ^ Result of rendering -parseErrorTextPretty (ParseError _ us ps xs) = - if E.null us && E.null ps && E.null xs - then "unknown parse error\n" - else concat - [ messageItemsPretty "unexpected " us - , messageItemsPretty "expecting " ps - , unlines (showErrorComponent <$> E.toAscList xs) ] +orList (x :| []) = x +orList (x :| [y]) = x <> " or " <> y +orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs diff --git a/Text/Megaparsec/Error.hs-boot b/Text/Megaparsec/Error.hs-boot new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Error.hs-boot @@ -0,0 +1,11 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE Safe #-} + +module Text.Megaparsec.Error + ( ParseError, + ) +where + +type role ParseError nominal nominal + +data ParseError s e diff --git a/Text/Megaparsec/Error/Builder.hs b/Text/Megaparsec/Error/Builder.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Error/Builder.hs @@ -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 +-- 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 :| [] diff --git a/Text/Megaparsec/Expr.hs b/Text/Megaparsec/Expr.hs deleted file mode 100644 --- a/Text/Megaparsec/Expr.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | --- Module : Text.Megaparsec.Expr --- Copyright : © 2015–2017 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : non-portable --- --- A helper module to parse expressions. It can build a parser given a table --- of operators. - -module Text.Megaparsec.Expr - ( Operator (..) - , makeExprParser ) -where - -import Control.Applicative ((<|>)) - -import Text.Megaparsec.Combinator -import Text.Megaparsec.Prim - --- | This data type specifies operators that work on values of type @a@. An --- operator is either binary infix or unary prefix or postfix. A binary --- operator has also an associated associativity. - -data Operator m a - = InfixN (m (a -> a -> a)) -- ^ Non-associative infix - | InfixL (m (a -> a -> a)) -- ^ Left-associative infix - | InfixR (m (a -> a -> a)) -- ^ Right-associative infix - | Prefix (m (a -> a)) -- ^ Prefix - | Postfix (m (a -> a)) -- ^ Postfix - --- | @makeExprParser term table@ builds an expression parser for terms --- @term@ with operators from @table@, taking the associativity and --- precedence specified in the @table@ into account. --- --- @table@ is a list of @[Operator m a]@ lists. The list is ordered in --- descending precedence. All operators in one list have the same precedence --- (but may have different associativity). --- --- Prefix and postfix operators of the same precedence associate to the left --- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). --- --- Unary operators of the same precedence can only occur once (i.e. @--2@ is --- not allowed if @-@ is prefix negate). If you need to parse several prefix --- or postfix operators in a row, (like C pointers—@**i@) you can use this --- approach: --- --- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp --- --- This is not done by default because in some cases allowing repeating --- prefix or postfix operators is not desirable. --- --- If you want to have an operator that is a prefix of another operator in --- the table, use the following (or similar) wrapper instead of plain --- 'symbol': --- --- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) --- --- @makeExprParser@ takes care of all the complexity involved in building an --- expression parser. Here is an example of an expression parser that --- handles prefix signs, postfix increment and basic arithmetic: --- --- > expr = makeExprParser term table "expression" --- > --- > term = parens expr <|> integer "term" --- > --- > table = [ [ prefix "-" negate --- > , prefix "+" id ] --- > , [ postfix "++" (+1) ] --- > , [ binary "*" (*) --- > , binary "/" div ] --- > , [ binary "+" (+) --- > , binary "-" (-) ] ] --- > --- > binary name f = InfixL (f <$ symbol name) --- > prefix name f = Prefix (f <$ symbol name) --- > postfix name f = Postfix (f <$ symbol name) - -makeExprParser :: MonadParsec e s m - => m a -- ^ Term parser - -> [[Operator m a]] -- ^ Operator table, see 'Operator' - -> m a -- ^ Resulting expression parser -makeExprParser = foldl addPrecLevel - --- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@ --- to parser @p@. - -addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a -addPrecLevel term ops = - term' >>= \x -> choice [ras' x, las' x, nas' x, return x] "operator" - where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops - term' = pTerm (choice prefix) term (choice postfix) - ras' = pInfixR (choice ras) term' - las' = pInfixL (choice las) term' - nas' = pInfixN (choice nas) term' - --- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional --- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are --- allowed to fail, in this case 'id' is used. - -pTerm :: MonadParsec e s m => m (a -> a) -> m a -> m (a -> a) -> m a -pTerm prefix term postfix = do - pre <- option id (hidden prefix) - x <- term - post <- option id (hidden postfix) - return . post . pre $ x - --- | @pInfixN op p x@ parses non-associative infix operator @op@, then term --- with parser @p@, then returns result of the operator application on @x@ --- and the term. - -pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixN op p x = do - f <- op - y <- p - return $ f x y - --- | @pInfixL op p x@ parses left-associative infix operator @op@, then term --- with parser @p@, then returns result of the operator application on @x@ --- and the term. - -pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixL op p x = do - f <- op - y <- p - let r = f x y - pInfixL op p r <|> return r - --- | @pInfixR op p x@ parses right-associative infix operator @op@, then --- term with parser @p@, then returns result of the operator application on --- @x@ and the term. - -pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixR op p x = do - f <- op - y <- p >>= \r -> pInfixR op p r <|> return r - return $ f x y - -type Batch m a = - ( [m (a -> a -> a)] - , [m (a -> a -> a)] - , [m (a -> a -> a)] - , [m (a -> a)] - , [m (a -> a)] ) - --- | A helper to separate various operators (binary, unary, and according to --- associativity) and return them in a tuple. - -splitOp :: Operator m a -> Batch m a -> Batch m a -splitOp (InfixR op) (r, l, n, pre, post) = (op:r, l, n, pre, post) -splitOp (InfixL op) (r, l, n, pre, post) = (r, op:l, n, pre, post) -splitOp (InfixN op) (r, l, n, pre, post) = (r, l, op:n, pre, post) -splitOp (Prefix op) (r, l, n, pre, post) = (r, l, n, op:pre, post) -splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post) diff --git a/Text/Megaparsec/Internal.hs b/Text/Megaparsec/Internal.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Internal.hs @@ -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 +-- 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 #-} diff --git a/Text/Megaparsec/Internal.hs-boot b/Text/Megaparsec/Internal.hs-boot new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Internal.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE RoleAnnotations #-} + +module Text.Megaparsec.Internal + ( Reply, + ) +where + +type role Reply nominal nominal representational + +data Reply e s a diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs --- a/Text/Megaparsec/Lexer.hs +++ b/Text/Megaparsec/Lexer.hs @@ -1,119 +1,91 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + -- | --- Module : Text.Megaparsec.Lexer --- Copyright : © 2015–2017 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen +-- Module : Text.Megaparsec.Common +-- Copyright : © 2018–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental --- Portability : non-portable --- --- High-level parsers to help you write your lexer. The module doesn't --- impose how you should write your parser, but certain approaches may be --- more elegant than others. Especially important theme is parsing of white --- space, comments, and indentation. +-- Portability : portable -- --- This module is intended to be imported qualified: +-- Common token combinators. This module is not public, the functions from +-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". -- --- > import qualified Text.Megaparsec.Lexer as L - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} - +-- @since 7.0.0 module Text.Megaparsec.Lexer ( -- * White space - space - , lexeme - , symbol - , symbol' - , skipLineComment - , skipBlockComment - , skipBlockCommentNested - -- * Indentation - , indentLevel - , incorrectIndent - , indentGuard - , nonIndented - , IndentOpt (..) - , indentBlock - , lineFold - -- * Character and string literals - , charLiteral - -- * Numbers - , integer - , decimal - , hexadecimal - , octal - , scientific - , float - , number - , signed ) + space, + lexeme, + symbol, + symbol', + ) where -import Control.Applicative -import Control.Monad (void) -import Data.Char (readLitChar) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (listToMaybe, fromMaybe, isJust) -import Data.Scientific (Scientific, toRealFloat) -import qualified Data.Set as E - -import Text.Megaparsec.Combinator -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import Text.Megaparsec.Prim -import qualified Text.Megaparsec.Char as C +import qualified Data.CaseInsensitive as CI +import Text.Megaparsec +import Text.Megaparsec.Common ---------------------------------------------------------------------------- -- White space --- | @space spaceChar lineComment blockComment@ produces parser that can --- parse white space in general. It's expected that you create such a parser --- once and pass it to other functions in this module as needed (when you --- see @spaceConsumer@ in documentation, usually it means that something --- like 'space' is expected there). +-- | @'space' sc lineComment blockComment@ produces a parser that can parse +-- white space in general. It's expected that you create such a parser once +-- and pass it to other functions in this module as needed (when you see +-- @spaceConsumer@ in documentation, usually it means that something like +-- 'space' is expected there). -- --- @spaceChar@ is used to parse trivial space characters. You can use --- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as --- your own parser (if you don't want to automatically consume newlines, for --- example). +-- @sc@ is used to parse blocks of space characters. You can use +-- 'Text.Megaparsec.Char.space1' from "Text.Megaparsec.Char" for this +-- purpose as well as your own parser (if you don't want to automatically +-- consume newlines, for example). Make sure that the parser does not +-- succeed on the empty input though. In an earlier version of the library +-- 'Text.Megaparsec.Char.spaceChar' was recommended, but now parsers based +-- on 'takeWhile1P' are preferred because of their speed. -- -- @lineComment@ is used to parse line comments. You can use --- 'skipLineComment' if you don't need anything special. +-- @skipLineComment@ if you don't need anything special. -- -- @blockComment@ is used to parse block (multi-line) comments. You can use --- 'skipBlockComment' if you don't need anything special. +-- @skipBlockComment@ or @skipBlockCommentNested@ if you don't need anything +-- special. -- --- Parsing of white space is an important part of any parser. We propose a --- convention where every lexeme parser assumes no spaces before the lexeme --- and consumes all spaces after the lexeme; this is what the 'lexeme' --- combinator does, and so it's enough to wrap every lexeme parser with --- 'lexeme' to achieve this. Note that you'll need to call 'space' manually --- to consume any white space before the first lexeme (i.e. at the beginning --- of the file). - -space :: MonadParsec e s m - => m () -- ^ A parser for a space character (e.g. @'void' 'C.spaceChar'@) - -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') - -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') - -> m () -space ch line block = hidden . skipMany $ choice [ch, line, block] +-- If you don't want to allow a kind of comment, simply pass 'empty' which +-- will fail instantly when parsing of that sort of comment is attempted and +-- 'space' will just move on or finish depending on whether there is more +-- white space for it to consume. +space :: + (MonadParsec e s m) => + -- | A parser for space characters which does not accept empty + -- input (e.g. 'Text.Megaparsec.Char.space1') + m () -> + -- | A parser for a line comment (e.g. 'skipLineComment') + m () -> + -- | A parser for a block comment (e.g. 'skipBlockComment') + m () -> + m () +space sp line block = + skipMany $ + choice + [hidden sp, hidden line, hidden block] +{-# INLINEABLE space #-} --- | This is a wrapper for lexemes. Typical usage is to supply the first +-- | This is a wrapper for lexemes. The typical usage is to supply the first -- argument (parser that consumes white space, probably defined via 'space') -- and use the resulting function to wrap parsers for every lexeme. -- -- > lexeme = L.lexeme spaceConsumer --- > integer = lexeme L.integer - -lexeme :: MonadParsec e s m - => m () -- ^ How to consume white space after lexeme - -> m a -- ^ How to parse actual lexeme - -> m a +-- > integer = lexeme L.decimal +lexeme :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | How to parse actual lexeme + m a -> + m a lexeme spc p = p <* spc +{-# INLINEABLE lexeme #-} -- | This is a helper to parse symbols, i.e. verbatim strings. You pass the -- first argument (parser that consumes white space, probably defined via @@ -129,370 +101,24 @@ -- > comma = symbol "," -- > colon = symbol ":" -- > dot = symbol "." - -symbol :: (MonadParsec e s m, Token s ~ Char) - => m () -- ^ How to consume white space after lexeme - -> String -- ^ String to parse - -> m String -symbol spc = lexeme spc . C.string +symbol :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse + Tokens s -> + m (Tokens s) +symbol spc = lexeme spc . string +{-# INLINEABLE symbol #-} --- | Case-insensitive version of 'symbol'. This may be helpful if you're +-- | A case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages. - -symbol' :: (MonadParsec e s m, Token s ~ Char) - => m () -- ^ How to consume white space after lexeme - -> String -- ^ String to parse (case-insensitive) - -> m String -symbol' spc = lexeme spc . C.string' - --- | Given comment prefix this function returns a parser that skips line --- comments. Note that it stops just before the newline character but --- doesn't consume the newline. Newline is either supposed to be consumed by --- 'space' parser or picked up manually. - -skipLineComment :: (MonadParsec e s m, Token s ~ Char) - => String -- ^ Line comment prefix - -> m () -skipLineComment prefix = p >> void (manyTill C.anyChar n) - where p = C.string prefix - n = lookAhead (void C.newline) <|> eof - --- | @skipBlockComment start end@ skips non-nested block comment starting --- with @start@ and ending with @end@. - -skipBlockComment :: (MonadParsec e s m, Token s ~ Char) - => String -- ^ Start of block comment - -> String -- ^ End of block comment - -> m () -skipBlockComment start end = p >> void (manyTill C.anyChar n) - where p = C.string start - n = C.string end - --- | @skipBlockCommentNested start end@ skips possibly nested block comment --- starting with @start@ and ending with @end@. --- --- @since 5.0.0 - -skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char) - => String -- ^ Start of block comment - -> String -- ^ End of block comment - -> m () -skipBlockCommentNested start end = p >> void (manyTill e n) - where e = skipBlockCommentNested start end <|> void C.anyChar - p = C.string start - n = C.string end - ----------------------------------------------------------------------------- --- Indentation - --- | Return the current indentation level. --- --- The function is a simple shortcut defined as: --- --- > indentLevel = sourceColumn <$> getPosition --- --- @since 4.3.0 - -indentLevel :: MonadParsec e s m => m Pos -indentLevel = sourceColumn <$> getPosition - --- | Fail reporting incorrect indentation error. The error has attached --- information: --- --- * Desired ordering between reference level and actual level --- * Reference indentation level --- * Actual indentation level --- --- @since 5.0.0 - -incorrectIndent :: MonadParsec e s m - => Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> Pos -- ^ Actual indentation level - -> m a -incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x) - where x = representIndentation ord ref actual - --- | @indentGuard spaceConsumer ord ref@ first consumes all white space --- (indentation) with @spaceConsumer@ parser, then it checks the column --- position. Ordering between current indentation level and the reference --- indentation level @ref@ should be @ord@, otherwise the parser fails. On --- success the current column position is returned. --- --- When you want to parse a block of indentation, first run this parser with --- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@—this will --- make sure you have some indentation. Use returned value to check --- indentation on every subsequent line according to syntax of your --- language. - -indentGuard :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> m Pos -- ^ Current column (indentation level) -indentGuard sc ord ref = do - sc - actual <- indentLevel - if compare actual ref == ord - then return actual - else incorrectIndent ord ref actual - --- | Parse a non-indented construction. This ensures that there is no --- indentation before actual data. Useful, for example, as a wrapper for --- top-level function definitions. --- --- @since 4.3.0 - -nonIndented :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> m a -- ^ How to parse actual data - -> m a -nonIndented sc p = indentGuard sc EQ (unsafePos 1) *> p - --- | The data type represents available behaviors for parsing of indented --- tokens. This is used in 'indentBlock', which see. --- --- @since 4.3.0 - -data IndentOpt m a b - = IndentNone a - -- ^ Parse no indented tokens, just return the value - | IndentMany (Maybe Pos) ([b] -> m a) (m b) - -- ^ Parse many indented tokens (possibly zero), use given indentation - -- level (if 'Nothing', use level of the first indented token); the - -- second argument tells how to get final result, and third argument - -- describes how to parse an indented token - | IndentSome (Maybe Pos) ([b] -> m a) (m b) - -- ^ Just like 'IndentMany', but requires at least one indented token to - -- be present - --- | Parse a “reference” token and a number of other tokens that have --- greater (but the same) level of indentation than that of “reference” --- token. Reference token can influence parsing, see 'IndentOpt' for more --- information. --- --- Tokens /must not/ consume newlines after them. On the other hand, the --- first argument of this function /must/ consume newlines among other white --- space characters. --- --- @since 4.3.0 - -indentBlock :: (MonadParsec e s m, Token s ~ Char) - => m () -- ^ How to consume indentation (white space) - -> m (IndentOpt m a b) -- ^ How to parse “reference” token - -> m a -indentBlock sc r = do - sc - ref <- indentLevel - a <- r - case a of - IndentNone x -> sc *> return x - IndentMany indent f p -> do - mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref) - done <- isJust <$> optional eof - case (mlvl, done) of - (Just lvl, False) -> - indentedItems ref (fromMaybe lvl indent) sc p >>= f - _ -> sc *> f [] - IndentSome indent f p -> do - lvl <- C.eol *> indentGuard sc GT ref - x <- p - xs <- indentedItems ref (fromMaybe lvl indent) sc p - f (x:xs) - --- | Grab indented items. This is a helper for 'indentBlock', it's not a --- part of the public API. - -indentedItems :: MonadParsec e s m - => Pos -- ^ Reference indentation level - -> Pos -- ^ Level of the first indented item ('lookAhead'ed) - -> m () -- ^ How to consume indentation (white space) - -> m b -- ^ How to parse indented tokens - -> m [b] -indentedItems ref lvl sc p = go - where - go = do - sc - pos <- indentLevel - done <- isJust <$> optional eof - if done - then return [] - else if | pos <= ref -> return [] - | pos == lvl -> (:) <$> p <*> go - | otherwise -> incorrectIndent EQ lvl pos - --- | Create a parser that supports line-folding. The first argument is used --- to consume white space between components of line fold, thus it /must/ --- consume newlines in order to work properly. The second argument is a --- callback that receives a custom space-consuming parser as argument. This --- parser should be used after separate components of line fold that can be --- put on different lines. --- --- An example should clarify the usage pattern: --- --- > sc = L.space (void spaceChar) empty empty --- > --- > myFold = L.lineFold sc $ \sc' -> do --- > L.symbol sc' "foo" --- > L.symbol sc' "bar" --- > L.symbol sc "baz" -- for the last symbol we use normal space consumer --- --- @since 5.0.0 - -lineFold :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> (m () -> m a) -- ^ Callback that uses provided space-consumer - -> m a -lineFold sc action = - sc >> indentLevel >>= action . void . indentGuard sc GT - ----------------------------------------------------------------------------- --- Character and string literals - --- | The lexeme parser parses a single literal character without quotes. The --- purpose of this parser is to help with parsing of conventional escape --- sequences. It's your responsibility to take care of character literal --- syntax in your language (by surrounding it with single quotes or --- similar). --- --- The literal character is parsed according to the grammar rules defined in --- the Haskell report. --- --- Note that you can use this parser as a building block to parse various --- string literals: --- --- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"') --- --- If you want to write @stringLiteral@ that adheres to the Haskell report --- though, you'll need to take care of the @\\&@ combination which is not a --- character, but can be used to separate characters (as in @\"\\291\\&4\"@ --- which is two characters long): --- --- > stringLiteral = catMaybes <$> (char '"' >> manyTill ch (char '"')) --- > where ch = (Just <$> L.charLiteral) <|> (Nothing <$ string "\\&") - -charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char -charLiteral = label "literal character" $ do - -- The @~@ is needed to avoid requiring a MonadFail constraint, - -- and we do know that r will be non-empty if count' succeeds. - ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar - case listToMaybe (readLitChar r) of - Just (c, r') -> count (length r - length r') C.anyChar >> return c - Nothing -> unexpected (Tokens (x:|[])) - ----------------------------------------------------------------------------- --- Numbers - --- | Parse an integer without sign in decimal representation (according to --- the format of integer literals described in the Haskell report). --- --- If you need to parse signed integers, see 'signed' combinator. - -integer :: (MonadParsec e s m, Token s ~ Char) => m Integer -integer = decimal "integer" - --- | The same as 'integer', but 'integer' is 'label'ed with “integer” label, --- while this parser is labeled with “decimal integer”. - -decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer -decimal = nump "" C.digitChar "decimal integer" - --- | Parse an integer in hexadecimal representation. Representation of --- hexadecimal number is expected to be according to the Haskell report --- except for the fact that this parser doesn't parse “0x” or “0X” prefix. --- It is a responsibility of the programmer to parse correct prefix before --- parsing the number itself. --- --- For example you can make it conform to Haskell report like this: --- --- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal - -hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer -hexadecimal = nump "0x" C.hexDigitChar "hexadecimal integer" - --- | Parse an integer in octal representation. Representation of octal --- number is expected to be according to the Haskell report except for the --- fact that this parser doesn't parse “0o” or “0O” prefix. It is a --- responsibility of the programmer to parse correct prefix before parsing --- the number itself. - -octal :: (MonadParsec e s m, Token s ~ Char) => m Integer -octal = nump "0o" C.octDigitChar "octal integer" - --- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then --- prepends @prefix@ to returned value and tries to interpret the result as --- an integer according to Haskell syntax. - -nump :: MonadParsec e s m => String -> m Char -> m Integer -nump prefix baseDigit = read . (prefix ++) <$> some baseDigit - --- | Parse a floating point value as a 'Scientific' number. 'Scientific' is --- great for parsing of arbitrary precision numbers coming from an untrusted --- source. See documentation in "Data.Scientific" for more information. --- Representation of the floating point value is expected to be according to --- the Haskell report. --- --- This function does not parse sign, if you need to parse signed numbers, --- see 'signed'. --- --- @since 5.0.0 - -scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific -scientific = label "floating point number" (read <$> f) - where f = (++) <$> some C.digitChar <*> (fraction <|> fExp) - --- | Parse a floating point number without sign. This is a simple shortcut --- defined as: --- --- > float = toRealFloat <$> scientific - -float :: (MonadParsec e s m, Token s ~ Char) => m Double -float = toRealFloat <$> scientific - --- | This is a helper for 'float' parser. It parses fractional part of --- floating point number, that is, dot and everything after it. - -fraction :: (MonadParsec e s m, Token s ~ Char) => m String -fraction = do - void (C.char '.') - d <- some C.digitChar - e <- option "" fExp - return ('.' : d ++ e) - --- | This helper parses exponent of floating point numbers. - -fExp :: (MonadParsec e s m, Token s ~ Char) => m String -fExp = do - expChar <- C.char' 'e' - signStr <- option "" (pure <$> choice (C.char <$> "+-")) - d <- some C.digitChar - return (expChar : signStr ++ d) - --- | Parse a number: either integer or floating point. The parser can handle --- overlapping grammars graciously. Use functions like --- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and --- extract integer or real values. - -number :: (MonadParsec e s m, Token s ~ Char) => m Scientific -number = label "number" (read <$> f) - where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp) - --- | @signed space p@ parser parses an optional sign, then if there is a --- sign it will consume optional white space (using @space@ parser), then it --- runs parser @p@ which should return a number. Sign of the number is --- changed according to previously parsed sign. --- --- For example, to parse signed integer you can write: --- --- > lexeme = L.lexeme spaceConsumer --- > integer = lexeme L.integer --- > signedInteger = L.signed spaceConsumer integer - -signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a -signed spc p = ($) <$> option id (lexeme spc sign) <*> p - --- | Parse a sign and return either 'id' or 'negate' according to parsed --- sign. - -sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a) -sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate) +symbol' :: + (MonadParsec e s m, CI.FoldCase (Tokens s)) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse (case-insensitive) + Tokens s -> + m (Tokens s) +symbol' spc = lexeme spc . string' +{-# INLINEABLE symbol' #-} diff --git a/Text/Megaparsec/Perm.hs b/Text/Megaparsec/Perm.hs deleted file mode 100644 --- a/Text/Megaparsec/Perm.hs +++ /dev/null @@ -1,146 +0,0 @@ --- | --- Module : Text.Megaparsec.Perm --- Copyright : © 2015–2017 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen --- License : FreeBSD --- --- Maintainer : Mark Karpov --- 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 diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs --- a/Text/Megaparsec/Pos.hs +++ b/Text/Megaparsec/Pos.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + -- | -- Module : Text.Megaparsec.Pos --- Copyright : © 2015–2017 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -8,92 +13,78 @@ -- Portability : portable -- -- Textual source position. The position includes name of file, line number, --- and column number. List of such positions can be used to model a stack of --- include files. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} - +-- and column number. +-- +-- You probably do not want to import this module directly because +-- "Text.Megaparsec" re-exports it anyway. module Text.Megaparsec.Pos ( -- * Abstract position - Pos - , mkPos - , unPos - , unsafePos - , InvalidPosException (..) + Pos, + mkPos, + unPos, + pos1, + defaultTabWidth, + InvalidPosException (..), + -- * Source position - , SourcePos (..) - , initialPos - , sourcePosPretty - -- * Helpers implementing default behaviors - , defaultUpdatePos - , defaultTabWidth ) + SourcePos (..), + initialPos, + sourcePosPretty, + ) where import Control.DeepSeq -import Control.Monad.Catch +import Control.Exception import Data.Data (Data) -import Data.Semigroup -import Data.Typeable (Typeable) import GHC.Generics -import Test.QuickCheck -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Word (Word) -#endif - ---------------------------------------------------------------------------- -- Abstract position --- | Positive integer that is used to represent line number, column number, --- and similar things like indentation level. 'Semigroup' instance can be --- used to safely and purely add 'Pos'es together. +-- | 'Pos' is the type for positive integers. This is used to represent line +-- number, column number, and similar things like indentation level. +-- 'Semigroup' instance can be used to safely and efficiently add 'Pos'es +-- together. -- -- @since 5.0.0 - -newtype Pos = Pos Word - deriving (Show, Eq, Ord, Data, Typeable, NFData) - -instance Arbitrary Pos where - arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0)) +newtype Pos = Pos Int + deriving (Show, Eq, Ord, Data, Generic, NFData) --- | Construction of 'Pos' from an instance of 'Integral'. The function --- throws 'InvalidPosException' when given non-positive argument. Note that --- the function is polymorphic with respect to 'MonadThrow' @m@, so you can --- get result inside of 'Maybe', for example. +-- | Construction of 'Pos' from 'Int'. The function throws +-- 'InvalidPosException' when given a non-positive argument. -- --- @since 5.0.0 - -mkPos :: (Integral a, MonadThrow m) => a -> m Pos -mkPos x = - if x < 1 - then throwM InvalidPosException - else (return . Pos . fromIntegral) x +-- @since 6.0.0 +mkPos :: Int -> Pos +mkPos a = + if a <= 0 + then throw (InvalidPosException a) + else Pos a {-# INLINE mkPos #-} --- | Dangerous construction of 'Pos'. Use when you know for sure that --- argument is positive. +-- | Extract 'Int' from 'Pos'. -- --- @since 5.0.0 +-- @since 6.0.0 +unPos :: Pos -> Int +unPos (Pos w) = w +{-# INLINE unPos #-} -unsafePos :: Word -> Pos -unsafePos x = - if x < 1 - then error "Text.Megaparsec.Pos.unsafePos" - else Pos x -{-# INLINE unsafePos #-} +-- | Position with value 1. +-- +-- @since 6.0.0 +pos1 :: Pos +pos1 = mkPos 1 --- | Extract 'Word' from 'Pos'. +-- | Value of tab width used by default. Always prefer this constant when +-- you want to refer to the default tab width because actual value /may/ +-- change in future. -- +-- Currently: +-- +-- > defaultTabWidth = mkPos 8 +-- -- @since 5.0.0 - -unPos :: Pos -> Word -unPos (Pos w) = w -{-# INLINE unPos #-} +defaultTabWidth :: Pos +defaultTabWidth = mkPos 8 instance Semigroup Pos where (Pos x) <> (Pos y) = Pos (x + y) @@ -103,92 +94,52 @@ readsPrec d = readParen (d > 10) $ \r1 -> do ("Pos", r2) <- lex r1 - (x, r3) <- readsPrec 11 r2 - (,r3) <$> mkPos (x :: Integer) - -instance Arbitrary SourcePos where - arbitrary = SourcePos - <$> sized (\n -> do - k <- choose (0, n `div` 2) - vectorOf k arbitrary) - <*> (unsafePos <$> choose (1, 1000)) - <*> (unsafePos <$> choose (1, 100)) + (x, r3) <- readsPrec 11 r2 + return (mkPos x, r3) -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number. -- -- @since 5.0.0 - -data InvalidPosException = InvalidPosException - deriving (Eq, Show, Data, Typeable, Generic) +newtype InvalidPosException + = -- | Contains the actual value that was passed to 'mkPos' + InvalidPosException Int + deriving (Eq, Show, Data, Generic) instance Exception InvalidPosException -instance NFData InvalidPosException +instance NFData InvalidPosException + ---------------------------------------------------------------------------- -- Source position --- | The data type @SourcePos@ represents source positions. It contains the +-- | The data type 'SourcePos' represents source positions. It contains the -- name of the source file, a line number, and a column number. Source line -- and column positions change intensively during parsing, so we need to -- make them strict to avoid memory leaks. - data SourcePos = SourcePos - { sourceName :: FilePath -- ^ Name of source file - , sourceLine :: !Pos -- ^ Line number - , sourceColumn :: !Pos -- ^ Column number - } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) + { -- | Name of source file + sourceName :: FilePath, + -- | Line number + sourceLine :: !Pos, + -- | Column number + sourceColumn :: !Pos + } + deriving (Show, Read, Eq, Ord, Data, Generic) instance NFData SourcePos -- | Construct initial position (line 1, column 1) given name of source -- file. - -initialPos :: String -> SourcePos -initialPos n = SourcePos n u u - where u = unsafePos 1 -{-# INLINE initialPos #-} +initialPos :: FilePath -> SourcePos +initialPos n = SourcePos n pos1 pos1 -- | Pretty-print a 'SourcePos'. -- -- @since 5.0.0 - sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c) - | null n = showLC - | otherwise = n ++ ":" ++ showLC - where showLC = show (unPos l) ++ ":" ++ show (unPos c) - ----------------------------------------------------------------------------- --- Helpers implementing default behaviors - --- | Update a source position given a character. The first argument --- specifies the tab width. If the character is a newline (\'\\n\') the line --- number is incremented by 1. If the character is a tab (\'\\t\') the --- column number is incremented to the nearest tab position. In all other --- cases, the column is incremented by 1. --- --- @since 5.0.0 - -defaultUpdatePos - :: Pos -- ^ Tab width - -> SourcePos -- ^ Current position - -> Char -- ^ Current token - -> (SourcePos, SourcePos) -- ^ Actual position and incremented position -defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos) + | null n = showLC + | otherwise = n <> ":" <> showLC where - u = unsafePos 1 - w = unPos width - c' = unPos c - npos = - case ch of - '\n' -> SourcePos n (l <> u) u - '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w)) - _ -> SourcePos n l (c <> u) - --- | Value of tab width used by default. Always prefer this constant when --- you want to refer to the default tab width because actual value /may/ --- change in future. - -defaultTabWidth :: Pos -defaultTabWidth = unsafePos 8 + showLC = show (unPos l) <> ":" <> show (unPos c) diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs deleted file mode 100644 --- a/Text/Megaparsec/Prim.hs +++ /dev/null @@ -1,1410 +0,0 @@ --- | --- Module : Text.Megaparsec.Prim --- Copyright : © 2015–2017 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : non-portable --- --- The primitive parser combinators. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK not-home #-} - -module Text.Megaparsec.Prim - ( -- * Data types - State (..) - , Stream (..) - , Parsec - , ParsecT - -- * Primitive combinators - , MonadParsec (..) - , () - , unexpected - , match - , region - -- * Parser state combinators - , getInput - , setInput - , getPosition - , getNextTokenPosition - , setPosition - , pushPosition - , popPosition - , getTokensProcessed - , setTokensProcessed - , getTabWidth - , setTabWidth - , setParserState - -- * Running parser - , parse - , parseMaybe - , parseTest - , runParser - , runParser' - , runParserT - , runParserT' - -- * Debugging - , dbg ) -where - -import Control.DeepSeq -import Control.Monad -import Control.Monad.Cont.Class -import Control.Monad.Error.Class -import Control.Monad.Identity -import Control.Monad.Reader.Class -import Control.Monad.State.Class hiding (state) -import Control.Monad.Trans -import Control.Monad.Trans.Identity -import Data.Data (Data) -import Data.Foldable (foldl') -import Data.List (genericTake) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid hiding ((<>)) -import Data.Proxy -import Data.Semigroup -import Data.Set (Set) -import Data.Typeable (Typeable) -import Debug.Trace -import GHC.Generics -import Prelude hiding (all) -import Test.QuickCheck hiding (Result (..), label) -import qualified Control.Applicative as A -import qualified Control.Monad.Fail as Fail -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.Trans.Reader as L -import qualified Control.Monad.Trans.State.Lazy as L -import qualified Control.Monad.Trans.State.Strict as S -import qualified Control.Monad.Trans.Writer.Lazy as L -import qualified Control.Monad.Trans.Writer.Strict as S -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Text.Megaparsec.Error -import Text.Megaparsec.Pos - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Word (Word) -#endif - ----------------------------------------------------------------------------- --- Data types - --- | This is the Megaparsec's state, it's parametrized over stream type @s@. - -data State s = State - { stateInput :: s - -- ^ Current input (already processed input is removed from the stream) - , statePos :: NonEmpty SourcePos - -- ^ Current position (column + line number) with support for include files - , stateTokensProcessed :: {-# UNPACK #-} !Word - -- ^ Number of processed tokens so far - -- - -- @since 5.2.0 - , stateTabWidth :: Pos - -- ^ Tab width to use - } deriving (Show, Eq, Data, Typeable, Generic) - -instance NFData s => NFData (State s) - -instance Arbitrary a => Arbitrary (State a) where - arbitrary = State - <$> arbitrary - <*> (NE.fromList . getNonEmpty <$> arbitrary) - <*> choose (1, 10000) - <*> (unsafePos <$> choose (1, 20)) - --- | All information available after parsing. This includes consumption of --- input, success (with returned value) or failure (with parse error), and --- parser state at the end of parsing. --- --- See also: 'Consumption', 'Result'. - -data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) - --- | This data structure represents an aspect of result of parser's work. --- --- See also: 'Result', 'Reply'. - -data Consumption - = Consumed -- ^ Some part of input stream was consumed - | Virgin -- ^ No input was consumed - --- | This data structure represents an aspect of result of parser's work. --- --- See also: 'Consumption', 'Reply'. - -data Result t e a - = OK a -- ^ Parser succeeded - | Error (ParseError t e) -- ^ Parser failed - --- | 'Hints' represent collection of strings to be included into --- 'ParserError' as “expected” message items when a parser fails without --- consuming input right after successful parser that produced the hints. --- --- For example, without hints you could get: --- --- >>> parseTest (many (char 'r') <* eof) "ra" --- 1:2: --- unexpected 'a' --- expecting end of input --- --- We're getting better error messages with help of hints: --- --- >>> parseTest (many (char 'r') <* eof) "ra" --- 1:2: --- unexpected 'a' --- expecting 'r' or end of input - -newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid) - --- | Convert 'ParseError' record into 'Hints'. - -toHints :: ParseError t e -> Hints t -toHints err = Hints hints - where hints = if E.null msgs then [] else [msgs] - msgs = errorExpected err -{-# INLINE toHints #-} - --- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. --- --- Note that if resulting continuation gets 'ParseError' that has only --- custom data in it (no “unexpected” or “expected” items), hints are --- ignored. - -withHints :: Ord (Token s) - => Hints (Token s) -- ^ Hints to use - -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence - -> ParseError (Token s) e -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> m b -withHints (Hints ps') c e@(ParseError pos us ps xs) = - if E.null us && E.null ps && not (E.null xs) - then c e - else c (ParseError pos us (E.unions (ps : ps')) xs) -{-# INLINE withHints #-} - --- | @accHints hs c@ results in “OK” continuation that will add given hints --- @hs@ to third argument of original continuation @c@. - -accHints - :: Hints t -- ^ 'Hints' to add - -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter - -> a -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> Hints t -- ^ Third argument of resulting continuation - -> m b -accHints hs1 c x s hs2 = c x s (hs1 <> hs2) -{-# INLINE accHints #-} - --- | Replace the most recent group of hints (if any) with the given --- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label' --- primitive. - -refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t -refreshLastHint (Hints []) _ = Hints [] -refreshLastHint (Hints (_:xs)) Nothing = Hints xs -refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) -{-# INLINE refreshLastHint #-} - --- | An instance of @Stream s@ has stream type @s@. Token type is determined --- by the stream and can be found via 'Token' type function. - -class Ord (Token s) => Stream s where - - -- | Type of token in stream. - -- - -- @since 5.0.0 - - type Token s :: * - - -- | Get next token from the stream. If the stream is empty, return - -- 'Nothing'. - - uncons :: s -> Maybe (Token s, s) - - -- | Update position in stream given tab width, current position, and - -- current token. The result is a tuple where the first element will be - -- used to report parse errors for current token, while the second element - -- is the incremented position that will be stored in the parser's state. - -- The stored (incremented) position is used whenever position can't - -- be\/shouldn't be updated by consuming a token. For example, when using - -- 'failure', we don't grab a new token (we need to fail right were we are - -- now), so error position will be taken from parser's state. - -- - -- When you work with streams where elements do not contain information - -- about their position in input, the result is usually consists of the - -- third argument unchanged and incremented position calculated with - -- respect to current token. This is how default instances of 'Stream' - -- work (they use 'defaultUpdatePos', which may be a good starting point - -- for your own position-advancing function). - -- - -- When you wish to deal with a stream of tokens where every token “knows” - -- its start and end position in input (for example, you have produced the - -- stream with Happy\/Alex), then the best strategy is to use the start - -- position as the actual element position and provide the end position of - -- the token as the incremented one. - -- - -- @since 5.0.0 - - updatePos - :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective) - -> Pos -- ^ Tab width - -> SourcePos -- ^ Current position - -> Token s -- ^ Current token - -> (SourcePos, SourcePos) -- ^ Actual position and incremented position - -instance Stream String where - type Token String = Char - uncons [] = Nothing - uncons (t:ts) = Just (t, ts) - {-# INLINE uncons #-} - updatePos = const defaultUpdatePos - {-# INLINE updatePos #-} - -instance Stream B.ByteString where - type Token B.ByteString = Char - uncons = B.uncons - {-# INLINE uncons #-} - updatePos = const defaultUpdatePos - {-# INLINE updatePos #-} - -instance Stream BL.ByteString where - type Token BL.ByteString = Char - uncons = BL.uncons - {-# INLINE uncons #-} - updatePos = const defaultUpdatePos - {-# INLINE updatePos #-} - -instance Stream T.Text where - type Token T.Text = Char - uncons = T.uncons - {-# INLINE uncons #-} - updatePos = const defaultUpdatePos - {-# INLINE updatePos #-} - -instance Stream TL.Text where - type Token TL.Text = Char - uncons = TL.uncons - {-# INLINE uncons #-} - updatePos = const defaultUpdatePos - {-# INLINE updatePos #-} - --- | @Parsec@ is a non-transformer variant of the more general 'ParsecT' --- monad transformer. - -type Parsec e s = ParsecT e s Identity - --- | @ParsecT e s m a@ is a parser with custom data component of error @e@, --- stream type @s@, underlying monad @m@ and return type @a@. - -newtype ParsecT e s m a = ParsecT - { unParser - :: forall b. State s - -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK - -> (ParseError (Token s) e -> State s -> m b) -- consumed-error - -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK - -> (ParseError (Token s) e -> State s -> m b) -- empty-error - -> m b } - -instance (ErrorComponent e, Stream s, Semigroup a) - => Semigroup (ParsecT e s m a) where - (<>) = A.liftA2 (<>) - {-# INLINE (<>) #-} - -instance (ErrorComponent e, Stream s, Monoid a) - => Monoid (ParsecT e s m a) where - mempty = pure mempty - {-# INLINE mempty #-} - mappend = A.liftA2 mappend - {-# INLINE mappend #-} - -instance Functor (ParsecT e s m) where - fmap = pMap - -pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b -pMap f p = ParsecT $ \s cok cerr eok eerr -> - unParser p s (cok . f) cerr (eok . f) eerr -{-# INLINE pMap #-} - -instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where - pure = pPure - (<*>) = pAp - p1 *> p2 = p1 `pBind` const p2 - p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } - -pAp :: Stream s - => ParsecT e s m (a -> b) - -> ParsecT e s m a - -> ParsecT e s m b -pAp m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (cok . x)) (withHints hs cerr) - meok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (eok . x)) (withHints hs eerr) - in unParser m s mcok cerr meok eerr -{-# INLINE pAp #-} - -instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where - empty = mzero - (<|>) = mplus - -instance (ErrorComponent e, Stream s) - => Monad (ParsecT e s m) where - return = pure - (>>=) = pBind - fail = Fail.fail - -pPure :: a -> ParsecT e s m a -pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty -{-# INLINE pPure #-} - -pBind :: Stream s - => ParsecT e s m a - -> (a -> ParsecT e s m b) - -> ParsecT e s m b -pBind m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser (k x) s' cok cerr - (accHints hs cok) (withHints hs cerr) - meok x s' hs = unParser (k x) s' cok cerr - (accHints hs eok) (withHints hs eerr) - in unParser m s mcok cerr meok eerr -{-# INLINE pBind #-} - -instance (ErrorComponent e, Stream s) - => Fail.MonadFail (ParsecT e s m) where - fail = pFail - -pFail :: ErrorComponent e => String -> ParsecT e s m a -pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos E.empty E.empty d) s - where d = E.singleton (representFail msg) -{-# INLINE pFail #-} - -mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a -mkPT k = ParsecT $ \s cok cerr eok eerr -> do - (Reply s' consumption result) <- k s - case consumption of - Consumed -> - case result of - OK x -> cok x s' mempty - Error e -> cerr e s' - Virgin -> - case result of - OK x -> eok x s' mempty - Error e -> eerr e s' - -instance (ErrorComponent e, Stream s, MonadIO m) - => MonadIO (ParsecT e s m) where - liftIO = lift . liftIO - -instance (ErrorComponent e, Stream s, MonadReader r m) - => MonadReader r (ParsecT e s m) where - ask = lift ask - local f p = mkPT $ \s -> local f (runParsecT p s) - -instance (ErrorComponent e, Stream s, MonadState st m) - => MonadState st (ParsecT e s m) where - get = lift get - put = lift . put - -instance (ErrorComponent e, Stream s, MonadCont m) - => MonadCont (ParsecT e s m) where - callCC f = mkPT $ \s -> - callCC $ \c -> - runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s - where pack s a = Reply s Virgin (OK a) - -instance (ErrorComponent e, Stream s, MonadError e' m) - => MonadError e' (ParsecT e s m) where - throwError = lift . throwError - p `catchError` h = mkPT $ \s -> - runParsecT p s `catchError` \e -> - runParsecT (h e) s - -instance (ErrorComponent e, Stream s) - => MonadPlus (ParsecT e s m) where - mzero = pZero - mplus = pPlus - -pZero :: ParsecT e s m a -pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos E.empty E.empty E.empty) s -{-# INLINE pZero #-} - -pPlus :: (ErrorComponent e, Stream s) - => ParsecT e s m a - -> ParsecT e s m a - -> ParsecT e s m a -pPlus m n = ParsecT $ \s cok cerr eok eerr -> - let meerr err ms = - let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') - neok x s' hs = eok x s' (toHints err <> hs) - neerr err' s' = eerr (err' <> err) (longestMatch ms s') - in unParser n s cok ncerr neok neerr - in unParser m s cok cerr eok meerr -{-# INLINE pPlus #-} - --- | From two states, return the one with the greater number of processed --- tokens. If the numbers of processed tokens are equal, prefer the second --- state. - -longestMatch :: State s -> State s -> State s -longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) = - case tp1 `compare` tp2 of - LT -> s2 - EQ -> s2 - GT -> s1 -{-# INLINE longestMatch #-} - -instance MonadTrans (ParsecT e s) where - lift amb = ParsecT $ \s _ _ eok _ -> - amb >>= \a -> eok a s mempty - ----------------------------------------------------------------------------- --- Primitive combinators - --- | Type class describing parsers independent of input type. - -class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m) - => MonadParsec e s m | m -> e s where - - -- | The most general way to stop parsing and report a 'ParseError'. - -- - -- 'unexpected' is defined in terms of this function: - -- - -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty - -- - -- @since 4.2.0 - - failure - :: Set (ErrorItem (Token s)) -- ^ Unexpected items - -> Set (ErrorItem (Token s)) -- ^ Expected items - -> Set e -- ^ Custom data - -> m a - - -- | The parser @label name p@ behaves as parser @p@, but whenever the - -- parser @p@ fails /without consuming any input/, it replaces names of - -- “expected” tokens with the name @name@. - - label :: String -> m a -> m a - - -- | @hidden p@ behaves just like parser @p@, but it doesn't show any - -- “expected” tokens in error message when @p@ fails. - - hidden :: m a -> m a - hidden = label "" - - -- | The parser @try p@ behaves like parser @p@, except that it backtracks - -- the parser state when @p@ fails (either consuming input or not). - -- - -- This combinator is used whenever arbitrary look ahead is needed. Since - -- it pretends that it hasn't consumed any input when @p@ fails, the - -- ('A.<|>') combinator will try its second alternative even when the - -- first parser failed while consuming input. - -- - -- For example, here is a parser that is supposed to parse the word “let” - -- or the word “lexical”: - -- - -- >>> parseTest (string "let" <|> string "lexical") "lexical" - -- 1:1: - -- unexpected "lex" - -- expecting "let" - -- - -- What happens here? The first parser consumes “le” and fails (because it - -- doesn't see a “t”). The second parser, however, isn't tried, since the - -- first parser has already consumed some input! 'try' fixes this behavior - -- and allows backtracking to work: - -- - -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" - -- "lexical" - -- - -- @try@ also improves error messages in case of overlapping alternatives, - -- because Megaparsec's hint system can be used: - -- - -- >>> parseTest (try (string "let") <|> string "lexical") "le" - -- 1:1: - -- unexpected "le" - -- expecting "let" or "lexical" - -- - -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks - -- automatically (see 'tokens'), so it does not need 'try'. However, the - -- examples above demonstrate the idea behind 'try' so well that it was - -- decided to keep them. You still need to use 'try' when your - -- alternatives are complex, composite parsers. - - try :: m a -> m a - - -- | If @p@ in @lookAhead p@ succeeds (either consuming input or not) the - -- whole parser behaves like @p@ succeeded without consuming anything - -- (parser state is not updated as well). If @p@ fails, @lookAhead@ has no - -- effect, i.e. it will fail consuming input if @p@ fails consuming input. - -- Combine with 'try' if this is undesirable. - - lookAhead :: m a -> m a - - -- | @notFollowedBy p@ only succeeds when the parser @p@ fails. This - -- parser /never consumes/ any input and /never modifies/ parser state. It - -- can be used to implement the “longest match” rule. - - notFollowedBy :: m a -> m () - - -- | @withRecovery r p@ allows continue parsing even if parser @p@ fails. - -- In this case @r@ is called with the actual 'ParseError' as its - -- argument. Typical usage is to return a value signifying failure to - -- parse this particular object and to consume some part of the input up - -- to the point where the next object starts. - -- - -- Note that if @r@ fails, original error message is reported as if - -- without 'withRecovery'. In no way recovering parser @r@ can influence - -- error messages. - -- - -- @since 4.4.0 - - withRecovery - :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure - -> m a -- ^ Original parser - -> m a -- ^ Parser that can recover from failures - - -- | @observing p@ allows to “observe” failure of the @p@ parser, should - -- it happen, without actually ending parsing, but instead getting the - -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' - -- as usual. Note that this primitive just allows you to observe parse - -- errors as they happen, it does not backtrack or change how the @p@ - -- parser works in any way. - -- - -- @since 5.1.0 - - observing - :: m a - -> m (Either (ParseError (Token s) e) a) - - -- | This parser only succeeds at the end of the input. - - eof :: m () - - -- | The parser @token test mrep@ accepts a token @t@ with result @x@ when - -- the function @test t@ returns @'Right' x@. @mrep@ may provide - -- representation of the token to report in error messages when input - -- stream in empty. - -- - -- This is the most primitive combinator for accepting tokens. For - -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: - -- - -- > satisfy f = token testChar Nothing - -- > where - -- > testChar x = - -- > if f x - -- > then Right x - -- > else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty) - - token - :: (Token s -> Either ( Set (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) - , Set e ) a) - -- ^ Matching function for the token to parse, it allows to construct - -- arbitrary error message on failure as well; sets in three-tuple - -- are: unexpected items, expected items, and custom data pieces - -> Maybe (Token s) -- ^ Token to report when input stream is empty - -> m a - - -- | The parser @tokens test@ parses a list of tokens and returns it. - -- Supplied predicate @test@ is used to check equality of given and parsed - -- tokens. - -- - -- This can be used for example to write 'Text.Megaparsec.Char.string': - -- - -- > string = tokens (==) - -- - -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking - -- primitive, which means that if it fails, it never consumes any input. - -- This is done to make its consumption model match how error messages for - -- this primitive are reported (which becomes an important thing as user - -- gets more control with primitives like 'withRecovery'): - -- - -- >>> parseTest (string "abc") "abd" - -- 1:1: - -- unexpected "abd" - -- expecting "abc" - -- - -- This means, in particular, that it's no longer necessary to use 'try' - -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and - -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect - -- performance in any way. - - tokens - :: (Token s -> Token s -> Bool) - -- ^ Predicate to check equality of tokens - -> [Token s] - -- ^ List of tokens to parse - -> m [Token s] - - -- | Return the full parser state as a 'State' record. - - getParserState :: m (State s) - - -- | @updateParserState f@ applies the function @f@ to the parser state. - - updateParserState :: (State s -> State s) -> m () - -instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where - failure = pFailure - label = pLabel - try = pTry - lookAhead = pLookAhead - notFollowedBy = pNotFollowedBy - withRecovery = pWithRecovery - observing = pObserving - eof = pEof - token = pToken - tokens = pTokens - getParserState = pGetParserState - updateParserState = pUpdateParserState - -pFailure - :: Set (ErrorItem (Token s)) - -> Set (ErrorItem (Token s)) - -> Set e - -> ParsecT e s m a -pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (ParseError pos us ps xs) s -{-# INLINE pFailure #-} - -pLabel :: String -> ParsecT e s m a -> ParsecT e s m a -pLabel l p = ParsecT $ \s cok cerr eok eerr -> - let el = Label <$> NE.nonEmpty l - cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l - cok' x s' hs = cok x s' (refreshLastHint hs cl) - eok' x s' hs = eok x s' (refreshLastHint hs el) - eerr' err = eerr err - { errorExpected = maybe E.empty E.singleton el } - in unParser p s cok' cerr eok' eerr' -{-# INLINE pLabel #-} - -pTry :: ParsecT e s m a -> ParsecT e s m a -pTry p = ParsecT $ \s cok _ eok eerr -> - let eerr' err _ = eerr err s - in unParser p s cok eerr' eok eerr' -{-# INLINE pTry #-} - -pLookAhead :: ParsecT e s m a -> ParsecT e s m a -pLookAhead p = ParsecT $ \s _ cerr eok eerr -> - let eok' a _ _ = eok a s mempty - in unParser p s eok' cerr eok' eerr -{-# INLINE pLookAhead #-} - -pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () -pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> - let what = maybe EndOfInput (Tokens . nes . fst) (uncons input) - unexpect u = ParseError pos (E.singleton u) E.empty E.empty - cok' _ _ _ = eerr (unexpect what) s - cerr' _ _ = eok () s mempty - eok' _ _ _ = eerr (unexpect what) s - eerr' _ _ = eok () s mempty - in unParser p s cok' cerr' eok' eerr' -{-# INLINE pNotFollowedBy #-} - -pWithRecovery - :: (ParseError (Token s) e -> ParsecT e s m a) - -> ParsecT e s m a - -> ParsecT e s m a -pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> - let mcerr err ms = - let rcok x s' _ = cok x s' mempty - rcerr _ _ = cerr err ms - reok x s' _ = eok x s' (toHints err) - reerr _ _ = cerr err ms - in unParser (r err) ms rcok rcerr reok reerr - meerr err ms = - let rcok x s' _ = cok x s' (toHints err) - rcerr _ _ = eerr err ms - reok x s' _ = eok x s' (toHints err) - reerr _ _ = eerr err ms - in unParser (r err) ms rcok rcerr reok reerr - in unParser p s cok mcerr eok meerr -{-# INLINE pWithRecovery #-} - -pObserving - :: ParsecT e s m a - -> ParsecT e s m (Either (ParseError (Token s) e) a) -pObserving p = ParsecT $ \s cok _ eok _ -> - let cerr' err s' = cok (Left err) s' mempty - eerr' err s' = eok (Left err) s' (toHints err) - in unParser p s (cok . Right) cerr' (eok . Right) eerr' -{-# INLINE pObserving #-} - -pEof :: forall e s m. Stream s => ParsecT e s m () -pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> - case uncons input of - Nothing -> eok () s mempty - Just (x,_) -> - let !apos = fst (updatePos (Proxy :: Proxy s) w pos x) - in eerr ParseError - { errorPos = apos:|z - , errorUnexpected = (E.singleton . Tokens . nes) x - , errorExpected = E.singleton EndOfInput - , errorCustom = E.empty } - (State input (apos:|z) tp w) -{-# INLINE pEof #-} - -pToken :: forall e s m a. Stream s - => (Token s -> Either ( Set (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) - , Set e ) a) - -> Maybe (Token s) - -> ParsecT e s m a -pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> - case uncons input of - Nothing -> eerr ParseError - { errorPos = pos:|z - , errorUnexpected = E.singleton EndOfInput - , errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtoken - , errorCustom = E.empty } s - Just (c,cs) -> - let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c - in case test c of - Left (us, ps, xs) -> - apos `seq` eerr - (ParseError (apos:|z) us ps xs) - (State input (apos:|z) tp w) - Right x -> - let newstate = State cs (npos:|z) (tp + 1) w - in npos `seq` cok x newstate mempty -{-# INLINE pToken #-} - -pTokens :: forall e s m. Stream s - => (Token s -> Token s -> Bool) - -> [Token s] - -> ParsecT e s m [Token s] -pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty -pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> - let updatePos' = updatePos (Proxy :: Proxy s) w - toTokens = Tokens . NE.fromList . reverse - unexpect pos' u = ParseError - { errorPos = pos' - , errorUnexpected = E.singleton u - , errorExpected = (E.singleton . Tokens . NE.fromList) tts - , errorCustom = E.empty } - go _ [] is rs = - let ris = reverse is - (npos, tp') = foldl' - (\(p, n) t -> (snd (updatePos' p t), n + 1)) - (pos, tp) - ris - in cok ris (State rs (npos:|z) tp' w) mempty - go apos (t:ts) is rs = - case uncons rs of - Nothing -> - apos `seq` eerr - (unexpect (apos:|z) (toTokens is)) - (State input (apos:|z) tp w) - Just (x,xs) -> - if test t x - then go apos ts (x:is) xs - else apos `seq` eerr - (unexpect (apos:|z) . toTokens $ x:is) - (State input (apos:|z) tp w) - in case uncons input of - Nothing -> - eerr (unexpect (pos:|z) EndOfInput) s - Just (x,xs) -> - let t:ts = tts - apos = fst (updatePos' pos x) - in if test t x - then go apos ts [x] xs - else apos `seq` eerr - (unexpect (apos:|z) $ Tokens (nes x)) - (State input (apos:|z) tp w) -{-# INLINE pTokens #-} - -pGetParserState :: ParsecT e s m (State s) -pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty -{-# INLINE pGetParserState #-} - -pUpdateParserState :: (State s -> State s) -> ParsecT e s m () -pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty -{-# INLINE pUpdateParserState #-} - --- | A synonym for 'label' in the form of an operator. - -infix 0 - -() :: MonadParsec e s m => m a -> String -> m a -() = flip label - --- | The parser @unexpected item@ fails with an error message telling about --- unexpected item @item@ without consuming any input. - -unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a -unexpected item = failure (E.singleton item) E.empty E.empty -{-# INLINE unexpected #-} - --- | Return both the result of a parse and the list of tokens that were --- consumed during parsing. This relies on the change of the --- 'stateTokensProcessed' value to evaluate how many tokens were consumed. --- --- @since 5.3.0 - -match :: MonadParsec e s m => m a -> m ([Token s], a) -match p = do - tp <- getTokensProcessed - s <- getInput - r <- p - tp' <- getTokensProcessed - return (streamTake (tp' - tp) s, r) - --- | Specify how to process 'ParseError's that happen inside of this --- wrapper. As a side effect of the current implementation changing --- 'errorPos' with this combinator will also change the final 'statePos' in --- the parser state. --- --- @since 5.3.0 - -region :: MonadParsec e s m - => (ParseError (Token s) e -> ParseError (Token s) e) - -- ^ How to process 'ParseError's - -> m a -- ^ The “region” that processing applies to - -> m a -region f m = do - r <- observing m - case r of - Left err -> do - let ParseError {..} = f err - updateParserState $ \st -> st { statePos = errorPos } - failure errorUnexpected errorExpected errorCustom - Right x -> return x - --- | Make a singleton non-empty list from a value. - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} - ----------------------------------------------------------------------------- --- Parser state combinators - --- | Return the current input. - -getInput :: MonadParsec e s m => m s -getInput = stateInput <$> getParserState - --- | @setInput input@ continues parsing with @input@. The 'getInput' and --- 'setInput' functions can for example be used to deal with include files. - -setInput :: MonadParsec e s m => s -> m () -setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w) - --- | Return the current source position. --- --- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'. - -getPosition :: MonadParsec e s m => m SourcePos -getPosition = NE.head . statePos <$> getParserState - --- | Get the position where the next token in the stream begins. If the --- stream is empty, return 'Nothing'. --- --- @since 5.3.0 - -getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos) -getNextTokenPosition = do - State {..} <- getParserState - let f = fst . updatePos (Proxy :: Proxy s) stateTabWidth (NE.head statePos) - return (f . fst <$> uncons stateInput) - --- | @setPosition pos@ sets the current source position to @pos@. --- --- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. - -setPosition :: MonadParsec e s m => SourcePos -> m () -setPosition pos = updateParserState $ \(State s (_:|z) tp w) -> - State s (pos:|z) tp w - --- | Push a position into stack of positions and continue parsing working --- with this position. Useful for working with include files and the like. --- --- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'. --- --- @since 5.0.0 - -pushPosition :: MonadParsec e s m => SourcePos -> m () -pushPosition pos = updateParserState $ \(State s z tp w) -> - State s (NE.cons pos z) tp w - --- | Pop a position from the stack of positions unless it only contains one --- element (in that case the stack of positions remains the same). This is --- how to return to previous source file after 'pushPosition'. --- --- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'. --- --- @since 5.0.0 - -popPosition :: MonadParsec e s m => m () -popPosition = updateParserState $ \(State s z tp w) -> - case snd (NE.uncons z) of - Nothing -> State s z tp w - Just z' -> State s z' tp w - --- | Get the number of tokens processed so far. --- --- @since 5.2.0 - -getTokensProcessed :: MonadParsec e s m => m Word -getTokensProcessed = stateTokensProcessed <$> getParserState - --- | Set the number of tokens processed so far. --- --- @since 5.2.0 - -setTokensProcessed :: MonadParsec e s m => Word -> m () -setTokensProcessed tp = updateParserState $ \(State s pos _ w) -> - State s pos tp w - --- | Return the tab width. The default tab width is equal to --- 'defaultTabWidth'. You can set a different tab width with the help of --- 'setTabWidth'. - -getTabWidth :: MonadParsec e s m => m Pos -getTabWidth = stateTabWidth <$> getParserState - --- | Set tab width. If the argument of the function is not a positive --- number, 'defaultTabWidth' will be used. - -setTabWidth :: MonadParsec e s m => Pos -> m () -setTabWidth w = updateParserState $ \(State s pos tp _) -> - State s pos tp w - --- | @setParserState st@ sets the parser state to @st@. - -setParserState :: MonadParsec e s m => State s -> m () -setParserState st = updateParserState (const st) - ----------------------------------------------------------------------------- --- Running a parser - --- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT' --- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a --- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn --- 'ParseError' into the string representation of the error message. See --- "Text.Megaparsec.Error" if you need to do more advanced error analysis. --- --- > main = case (parse numbers "" "11,2,43") of --- > Left err -> putStr (parseErrorPretty err) --- > Right xs -> print (sum xs) --- > --- > numbers = integer `sepBy` char ',' - -parse - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a -parse = runParser - --- | @parseMaybe p input@ runs the parser @p@ on @input@ and returns the --- result inside 'Just' on success and 'Nothing' on failure. This function --- also parses 'eof', so if the parser doesn't consume all of its input, it --- will fail. --- --- The function is supposed to be useful for lightweight parsing, where --- error messages (and thus file name) are not important and entire input --- should be parsed. For example it can be used when parsing of a single --- number according to specification of its format is desired. - -parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a -parseMaybe p s = - case parse (p <* eof) "" s of - Left _ -> Nothing - Right x -> Just x - --- | The expression @parseTest p input@ applies the parser @p@ against input --- @input@ and prints the result to stdout. Useful for testing. - -parseTest :: ( ShowErrorComponent e - , Ord (Token s) - , ShowToken (Token s) - , Show a ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () -parseTest p input = - case parse p "" input of - Left e -> putStr (parseErrorPretty e) - Right x -> print x - --- | @runParser p file input@ runs parser @p@ on the input stream of tokens --- @input@, obtained from source @file@. The @file@ is only used in error --- messages and may be the empty string. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). --- --- > parseFromFile p file = runParser p file <$> readFile file - -runParser - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a -runParser p name s = snd $ runParser' p (initialState name s) - --- | The function is similar to 'runParser' with the difference that it --- accepts and returns parser state. This allows to specify arbitrary --- textual position at the beginning of parsing, for example. This is the --- most general way to run a parser over the 'Identity' monad. --- --- @since 4.2.0 - -runParser' - :: Parsec e s a -- ^ Parser to run - -> State s -- ^ Initial state - -> (State s, Either (ParseError (Token s) e) a) -runParser' p = runIdentity . runParserT' p - --- | @runParserT p file input@ runs parser @p@ on the input list of tokens --- @input@, obtained from source @file@. The @file@ is only used in error --- messages and may be the empty string. Returns a computation in the --- underlying monad @m@ that returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). - -runParserT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> m (Either (ParseError (Token s) e) a) -runParserT p name s = snd `liftM` runParserT' p (initialState name s) - --- | This function is similar to 'runParserT', but like 'runParser'' it --- accepts and returns parser state. This is thus the most general way to --- run a parser. --- --- @since 4.2.0 - -runParserT' :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (State s, Either (ParseError (Token s) e) a) -runParserT' p s = do - (Reply s' _ result) <- runParsecT p s - case result of - OK x -> return (s', Right x) - Error e -> return (s', Left e) - --- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' --- are built upon this. - -runParsecT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (Reply e s a) -runParsecT p s = unParser p s cok cerr eok eerr - where cok a s' _ = return $ Reply s' Consumed (OK a) - cerr err s' = return $ Reply s' Consumed (Error err) - eok a s' _ = return $ Reply s' Virgin (OK a) - eerr err s' = return $ Reply s' Virgin (Error err) - --- | Given name of source file and input construct initial state for parser. - -initialState :: String -> s -> State s -initialState name s = State - { stateInput = s - , statePos = initialPos name :| [] - , stateTokensProcessed = 0 - , stateTabWidth = defaultTabWidth } - ----------------------------------------------------------------------------- --- Instances of 'MonadParsec' - -instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where - failure us ps xs = lift (failure us ps xs) - label n (L.StateT m) = L.StateT $ label n . m - try (L.StateT m) = L.StateT $ try . m - lookAhead (L.StateT m) = L.StateT $ \s -> - (,s) . fst <$> lookAhead (m s) - notFollowedBy (L.StateT m) = L.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) - withRecovery r (L.StateT m) = L.StateT $ \s -> - withRecovery (\e -> L.runStateT (r e) s) (m s) - observing (L.StateT m) = L.StateT $ \s -> - fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where - failure us ps xs = lift (failure us ps xs) - label n (S.StateT m) = S.StateT $ label n . m - try (S.StateT m) = S.StateT $ try . m - lookAhead (S.StateT m) = S.StateT $ \s -> - (,s) . fst <$> lookAhead (m s) - notFollowedBy (S.StateT m) = S.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) - withRecovery r (S.StateT m) = S.StateT $ \s -> - withRecovery (\e -> S.runStateT (r e) s) (m s) - observing (S.StateT m) = S.StateT $ \s -> - fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where - failure us ps xs = lift (failure us ps xs) - label n (L.ReaderT m) = L.ReaderT $ label n . m - try (L.ReaderT m) = L.ReaderT $ try . m - lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m - notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m - withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> - withRecovery (\e -> L.runReaderT (r e) s) (m s) - observing (L.ReaderT m) = L.ReaderT $ observing . m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where - failure us ps xs = lift (failure us ps xs) - label n (L.WriterT m) = L.WriterT $ label n m - try (L.WriterT m) = L.WriterT $ try m - lookAhead (L.WriterT m) = L.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (L.WriterT m) = L.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (L.WriterT m) = L.WriterT $ - withRecovery (L.runWriterT . r) m - observing (L.WriterT m) = L.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where - failure us ps xs = lift (failure us ps xs) - label n (S.WriterT m) = S.WriterT $ label n m - try (S.WriterT m) = S.WriterT $ try m - lookAhead (S.WriterT m) = S.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (S.WriterT m) = S.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (S.WriterT m) = S.WriterT $ - withRecovery (S.runWriterT . r) m - observing (S.WriterT m) = S.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where - failure us ps xs = lift (failure us ps xs) - label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) - try (L.RWST m) = L.RWST $ \r s -> try (m r s) - lookAhead (L.RWST m) = L.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (L.RWST m) = L.RWST $ \r s -> do - notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (L.RWST m) = L.RWST $ \r s -> - withRecovery (\e -> L.runRWST (n e) r s) (m r s) - observing (L.RWST m) = L.RWST $ \r s -> - fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where - failure us ps xs = lift (failure us ps xs) - label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) - try (S.RWST m) = S.RWST $ \r s -> try (m r s) - lookAhead (S.RWST m) = S.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (S.RWST m) = S.RWST $ \r s -> do - notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (S.RWST m) = S.RWST $ \r s -> - withRecovery (\e -> S.runRWST (n e) r s) (m r s) - observing (S.RWST m) = S.RWST $ \r s -> - fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (IdentityT m) where - failure us ps xs = lift (failure us ps xs) - label n (IdentityT m) = IdentityT $ label n m - try = IdentityT . try . runIdentityT - lookAhead (IdentityT m) = IdentityT $ lookAhead m - notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - withRecovery r (IdentityT m) = IdentityT $ - withRecovery (runIdentityT . r) m - observing (IdentityT m) = IdentityT $ observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift $ tokens e ts - getParserState = lift getParserState - updateParserState f = lift $ updateParserState f - -fixs :: s -> Either a (b, s) -> (Either a b, s) -fixs s (Left a) = (Left a, s) -fixs _ (Right (b, s)) = (Right b, s) -{-# INLINE fixs #-} - -fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) -fixs' s (Left a) = (Left a, s, mempty) -fixs' _ (Right (b,s,w)) = (Right b, s, w) -{-# INLINE fixs' #-} - ----------------------------------------------------------------------------- --- Debugging - --- | @dbg label p@ parser works exactly like @p@, but when it's evaluated it --- also prints information useful for debugging. The @label@ is only used to --- refer to this parser in the debugging output. This combinator uses the --- 'trace' function from "Debug.Trace" under the hood. --- --- Typical usage is to wrap every sub-parser in misbehaving parser with --- 'dbg' assigning meaningful labels. Then give it a shot and go through the --- print-out. As of current version, this combinator prints all available --- information except for /hints/, which are probably only interesting to --- the maintainer of Megaparsec itself and may be quite verbose to output in --- general. Let me know if you would like to be able to see hints in the --- debugging output. --- --- The output itself is pretty self-explanatory, although the following --- abbreviations should be clarified (they are derived from the low-level --- source code): --- --- * @COK@—“consumed OK”. The parser consumed input and succeeded. --- * @CERR@—“consumed error”. The parser consumed input and failed. --- * @EOK@—“empty OK”. The parser succeeded without consuming input. --- * @EERR@—“empty error”. The parser failed without consuming input. --- --- Finally, it's not possible to lift this function into some monad --- transformers without introducing surprising behavior (e.g. unexpected --- state backtracking) or adding otherwise redundant constraints (e.g. --- 'Show' instance for state), so this helper is only available for --- 'ParsecT' monad, not 'MonadParsec' in general. --- --- @since 5.1.0 - -dbg :: forall e s m a. - ( Stream s - , ShowToken (Token s) - , ShowErrorComponent e - , Show a ) - => String -- ^ Debugging label - -> ParsecT e s m a -- ^ Parser to debug - -> ParsecT e s m a -- ^ Parser that prints debugging messages -dbg lbl p = ParsecT $ \s cok cerr eok eerr -> - let l = dbgLog lbl :: DbgItem s e a -> String - cok' x s' hs = flip trace (cok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x) - cerr' err s' = flip trace (cerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err) - eok' x s' hs = flip trace (eok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x) - eerr' err s' = flip trace (eerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err) - in unParser p s cok' cerr' eok' eerr' - --- | A single piece of info to be rendered with 'dbgLog'. - -data DbgItem s e a - = DbgIn [Token s] - | DbgCOK [Token s] a - | DbgCERR [Token s] (ParseError (Token s) e) - | DbgEOK [Token s] a - | DbgEERR [Token s] (ParseError (Token s) e) - --- | Render a single piece of debugging info. - -dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s)) - => String -- ^ Debugging label - -> DbgItem s e a -- ^ Information to render - -> String -- ^ Rendered result -dbgLog lbl item = prefix msg - where - prefix = unlines . fmap ((lbl ++ "> ") ++) . lines - msg = case item of - DbgIn ts -> - "IN: " ++ showStream ts - DbgCOK ts a -> - "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a - DbgCERR ts e -> - "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e - DbgEOK ts a -> - "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a - DbgEERR ts e -> - "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e - --- | Pretty-print a list of tokens. - -showStream :: ShowToken t => [t] -> String -showStream ts = - case NE.nonEmpty ts of - Nothing -> "" - Just ne -> - let (h, r) = splitAt 40 (showTokens ne) - in if null r then h else h ++ " <…>" - --- | Calculate number of consumed tokens given 'State' of parser before and --- after parsing. - -streamDelta - :: State s -- ^ State of parser before consumption - -> State s -- ^ State of parser after consumption - -> Word -- ^ Number of consumed tokens -streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0 - --- | Extract a given number of tokens from the stream. - -streamTake :: Stream s => Word -> s -> [Token s] -streamTake n s = genericTake n (unfold s) - --- | A custom version of 'unfold' that matches signature of the 'uncons' --- method in the 'Stream' type class we use. - -unfold :: Stream s => s -> [Token s] -unfold s = case uncons s of - Nothing -> [] - Just (t, s') -> t : unfold s' diff --git a/Text/Megaparsec/State.hs b/Text/Megaparsec/State.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/State.hs @@ -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 +-- 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 = "" + } diff --git a/Text/Megaparsec/Stream.hs b/Text/Megaparsec/Stream.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Stream.hs @@ -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 +-- 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 @\"\\"@. + -- * 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 + "" -> "" + 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 diff --git a/Text/Megaparsec/String.hs b/Text/Megaparsec/String.hs deleted file mode 100644 --- a/Text/Megaparsec/String.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | --- Module : Text.Megaparsec.String --- Copyright : © 2015–2017 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Convenience definitions for working with 'String' as input stream. - -module Text.Megaparsec.String (Parser) where - -import Text.Megaparsec.Error (Dec) -import Text.Megaparsec.Prim - --- | Modules corresponding to various types of streams define 'Parser' --- accordingly, so the user can use it to easily change type of input stream --- by importing different “type modules”. This one is for 'String's. - -type Parser = Parsec Dec String diff --git a/Text/Megaparsec/Text.hs b/Text/Megaparsec/Text.hs deleted file mode 100644 --- a/Text/Megaparsec/Text.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | --- Module : Text.Megaparsec.Text --- Copyright : © 2015–2017 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Convenience definitions for working with strict 'Text'. - -module Text.Megaparsec.Text (Parser) where - -import Text.Megaparsec.Error (Dec) -import Text.Megaparsec.Prim -import Data.Text - --- | Modules corresponding to various types of streams define 'Parser' --- accordingly, so the user can use it to easily change type of input stream --- by importing different “type modules”. This one is for strict 'Text'. - -type Parser = Parsec Dec Text diff --git a/Text/Megaparsec/Text/Lazy.hs b/Text/Megaparsec/Text/Lazy.hs deleted file mode 100644 --- a/Text/Megaparsec/Text/Lazy.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- Module : Text.Megaparsec.Text.Lazy --- Copyright : © 2015–2017 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Convenience definitions for working with lazy 'Text'. - -module Text.Megaparsec.Text.Lazy (Parser) where - -import Data.Text.Lazy -import Text.Megaparsec.Error (Dec) -import Text.Megaparsec.Prim - --- | Modules corresponding to various types of streams define 'Parser' --- accordingly, so the user can use it to easily change type of the input --- stream by importing different “type modules”. This one is for lazy --- 'Text'. - -type Parser = Parsec Dec Text diff --git a/Text/Megaparsec/Unicode.hs b/Text/Megaparsec/Unicode.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Unicode.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Text.Megaparsec.Unicode +-- Copyright : © 2024–present Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- 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 #-} diff --git a/bench-memory/Main.hs b/bench-memory/Main.hs deleted file mode 100644 --- a/bench-memory/Main.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Main (main) where - -import Control.DeepSeq -import Control.Monad -import Text.Megaparsec -import Text.Megaparsec.String -import Weigh - -main :: IO () -main = mainWith $ do - setColumns [Case, Allocated, GCs, Max] - bparser "string" manyAs (string . fst) - bparser "string'" manyAs (string' . fst) - bparser "choice" (const "b") (choice . fmap char . manyAsB . snd) - bparser "many" manyAs (const $ many (char 'a')) - bparser "some" manyAs (const $ some (char 'a')) - bparser "count" manyAs (\(_,n) -> count n (char 'a')) - bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) - bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) - bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) - bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) - bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - --- | Perform a series of measurements with the same parser. - -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> String) -- ^ How to construct input - -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input - -> Weigh () -bparser name f p = forM_ stdSeries $ \i -> do - let arg = (f i,i) - p' (s,n) = parse (p (s,n)) "" s - func (name ++ "/" ++ show i) p' arg - --- | The series of sizes to try as part of 'bparser'. - -stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] - ----------------------------------------------------------------------------- --- Helpers - --- | Generate that many \'a\' characters. - -manyAs :: Int -> String -manyAs n = replicate n 'a' - --- | Like 'manyAs', but interspersed with \'b\'s. - -manyAbs :: Int -> String -manyAbs n = take (if even n then n + 1 else n) (cycle "ab") - --- | Like 'manyAs', but with a \'b\' added to the end. - -manyAsB :: Int -> String -manyAsB n = replicate n 'a' ++ "b" - --- | Like 'manyAbs', but ends in a \'b\'. - -manyAbs' :: Int -> String -manyAbs' n = take (if even n then n else n + 1) (cycle "ab") diff --git a/bench-speed/Main.hs b/bench-speed/Main.hs deleted file mode 100644 --- a/bench-speed/Main.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Main (main) where - -import Control.DeepSeq -import Criterion.Main -import Text.Megaparsec -import Text.Megaparsec.String - -main :: IO () -main = defaultMain - [ bparser "string" manyAs (string . fst) - , bparser "string'" manyAs (string' . fst) - , bparser "choice" (const "b") (choice . fmap char . manyAsB . snd) - , bparser "many" manyAs (const $ many (char 'a')) - , bparser "some" manyAs (const $ some (char 'a')) - , bparser "count" manyAs (\(_,n) -> count n (char 'a')) - , bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - , bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - , bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) - , bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - , bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - , bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) - , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) - , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) - , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - ] - --- | Perform a series to measurements with the same parser. - -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> String) -- ^ How to construct input - -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input - -> Benchmark -- ^ The benchmark -bparser name f p = bgroup name (bs <$> stdSeries) - where - bs n = env (return (f n, n)) (bench (show n) . nf p') - p' (s,n) = parse (p (s,n)) "" s - --- | The series of sizes to try as part of 'bparser'. - -stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] - ----------------------------------------------------------------------------- --- Helpers - --- | Generate that many \'a\' characters. - -manyAs :: Int -> String -manyAs n = replicate n 'a' - --- | Like 'manyAs', but with a \'b\' added to the end. - -manyAsB :: Int -> String -manyAsB n = replicate n 'a' ++ "b" - --- | Like 'manyAs', but interspersed with \'b\'s and ends in a \'a\'. - -manyAbs :: Int -> String -manyAbs n = take (if even n then n + 1 else n) (cycle "ab") - --- | Like 'manyAbs', but ends in a \'b\'. - -manyAbs' :: Int -> String -manyAbs' n = take (if even n then n else n + 1) (cycle "ab") diff --git a/bench/memory/Main.hs b/bench/memory/Main.hs new file mode 100644 --- /dev/null +++ b/bench/memory/Main.hs @@ -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)) diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs new file mode 100644 --- /dev/null +++ b/bench/speed/Main.hs @@ -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)) diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -1,141 +1,127 @@ -name: megaparsec -version: 5.3.1 -cabal-version: >= 1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 -license: BSD2 -license-file: LICENSE.md -author: Megaparsec contributors, - Paolo Martini , - Daan Leijen +cabal-version: 2.4 +name: megaparsec +version: 9.8.1 +license: BSD-2-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +author: + Megaparsec contributors, + Paolo Martini , + Daan Leijen -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/megaparsec -bug-reports: https://github.com/mrkkrp/megaparsec/issues -category: Parsing -synopsis: Monadic parser combinators -build-type: Simple -description: +tested-with: + ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1 - This is industrial-strength monadic parser combinator library. Megaparsec - is a fork of Parsec library originally written by Daan Leijen. +homepage: https://github.com/mrkkrp/megaparsec +bug-reports: https://github.com/mrkkrp/megaparsec/issues +synopsis: Monadic parser combinators +description: + This is an industrial-strength monadic parser combinator library. + Megaparsec is a feature-rich package that tries to find a nice balance + between speed, flexibility, and quality of parse errors. -extra-doc-files: AUTHORS.md - , CHANGELOG.md - , README.md +category: Parsing +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/mrkkrp/megaparsec.git + type: git + location: https://github.com/mrkkrp/megaparsec.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: QuickCheck >= 2.7 && < 2.11 - , base >= 4.7 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.6 - , deepseq >= 1.3 && < 1.5 - , exceptions >= 0.6 && < 0.9 - , mtl >= 2.0 && < 3.0 - , scientific >= 0.3.1 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 + exposed-modules: + Text.Megaparsec + Text.Megaparsec.Byte + Text.Megaparsec.Byte.Binary + Text.Megaparsec.Byte.Lexer + Text.Megaparsec.Char + Text.Megaparsec.Char.Lexer + Text.Megaparsec.Debug + Text.Megaparsec.Error + Text.Megaparsec.Error.Builder + Text.Megaparsec.Internal + Text.Megaparsec.Pos + Text.Megaparsec.State + Text.Megaparsec.Stream + Text.Megaparsec.Unicode - if !impl(ghc >= 8.0) - -- packages providing modules that moved into base-4.9.0.0 - build-depends: fail == 4.9.* - , semigroups == 0.18.* + other-modules: + Text.Megaparsec.Class + Text.Megaparsec.Common + Text.Megaparsec.Lexer - if !impl(ghc >= 7.8) - build-depends: tagged == 0.8.* + default-language: Haskell2010 + build-depends: + array >=0.5.3 && <0.6, + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + mtl >=2.2.2 && <3, + parser-combinators >=1.0 && <2, + scientific >=0.3.7 && <0.4, + text >=0.2 && <2.2, + transformers >=0.4 && <0.7 - exposed-modules: Text.Megaparsec - , Text.Megaparsec.ByteString - , Text.Megaparsec.ByteString.Lazy - , Text.Megaparsec.Char - , Text.Megaparsec.Combinator - , Text.Megaparsec.Error - , Text.Megaparsec.Expr - , Text.Megaparsec.Lexer - , Text.Megaparsec.Perm - , Text.Megaparsec.Pos - , Text.Megaparsec.Prim - , Text.Megaparsec.String - , Text.Megaparsec.Text - , Text.Megaparsec.Text.Lazy - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages -test-suite tests - main-is: Spec.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - other-modules: Test.Hspec.Megaparsec - , Test.Hspec.Megaparsec.AdHoc - , Text.Megaparsec.CharSpec - , Text.Megaparsec.CombinatorSpec - , Text.Megaparsec.ErrorSpec - , Text.Megaparsec.ExprSpec - , Text.Megaparsec.LexerSpec - , Text.Megaparsec.PermSpec - , Text.Megaparsec.PosSpec - , Text.Megaparsec.PrimSpec - build-depends: QuickCheck >= 2.7 && < 2.11 - , base >= 4.7 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.6 - , exceptions >= 0.6 && < 0.9 - , hspec >= 2.0 && < 3.0 - , hspec-expectations >= 0.5 && < 0.9 - , megaparsec - , mtl >= 2.0 && < 3.0 - , scientific >= 0.3.1 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 + else + ghc-options: -O2 -Wall - if !impl(ghc >= 8.0) - -- packages providing modules that moved into base-4.9.0.0 - build-depends: semigroups == 0.18.* + if impl(ghc >=9.8) + ghc-options: -Wno-x-partial - if !impl(ghc >= 7.8) - build-depends: tagged == 0.8.* +benchmark bench-speed + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/speed + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + criterion >=0.6.2.1 && <1.7, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2 - default-language: Haskell2010 + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages -benchmark bench-speed - main-is: Main.hs - hs-source-dirs: bench-speed - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , criterion >= 0.6.2.1 && < 1.3 - , deepseq >= 1.3 && < 1.5 - , megaparsec - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + else + ghc-options: -O2 -Wall benchmark bench-memory - main-is: Main.hs - hs-source-dirs: bench-memory - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , deepseq >= 1.3 && < 1.5 - , megaparsec - , weigh >= 0.0.4 - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/memory + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2, + weigh >=0.0.4 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 --- a/tests/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs deleted file mode 100644 --- a/tests/Test/Hspec/Megaparsec.hs +++ /dev/null @@ -1,387 +0,0 @@ --- | --- Module : Test.Hspec.Megaparsec --- Copyright : © 2016–2017 Mark Karpov --- License : BSD 3 clause --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Utility functions for testing Megaparsec parsers with Hspec. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Hspec.Megaparsec - ( -- * Basic expectations - shouldParse - , parseSatisfies - , shouldSucceedOn - , shouldFailOn - -- * Testing of error messages - , shouldFailWith - -- * Error message construction - -- $errmsg - , err - , posI - , posN - , EC - , utok - , utoks - , ulabel - , ueof - , etok - , etoks - , elabel - , eeof - , cstm - -- * Incremental parsing - , failsLeaving - , succeedsLeaving - , initialState ) -where - -import Control.Monad (unless) -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Proxy -import Data.Semigroup -import Data.Set (Set) -import Data.Typeable (Typeable) -import GHC.Generics -import Test.Hspec.Expectations -import Text.Megaparsec -import Text.Megaparsec.Pos (defaultTabWidth) -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E - ----------------------------------------------------------------------------- --- Basic expectations - --- | Create an expectation by saying what the result should be. --- --- > parse letterChar "" "x" `shouldParse` 'x' - -shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a) - => Either (ParseError t e) a - -- ^ Result of parsing as returned by function like 'parse' - -> a -- ^ Desired result - -> Expectation -r `shouldParse` v = case r of - Left e -> expectationFailure $ "expected: " ++ show v ++ - "\nbut parsing failed with error:\n" ++ showParseError e - Right x -> unless (x == v) . expectationFailure $ - "expected: " ++ show v ++ "\nbut got: " ++ show x - --- | Create an expectation by saying that the parser should successfully --- parse a value and that the value should satisfy some predicate. --- --- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length) - -parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -- ^ Result of parsing as returned by function like 'parse' - -> (a -> Bool) -- ^ Predicate - -> Expectation -r `parseSatisfies` p = case r of - Left e -> expectationFailure $ - "expected a parsed value to check against the predicate" ++ - "\nbut parsing failed with error:\n" ++ showParseError e - Right x -> unless (p x) . expectationFailure $ - "the value did not satisfy the predicate: " ++ show x - --- | Check that a parser fails on a given input. --- --- > parse (char 'x') "" `shouldFailOn` "a" - -shouldFailOn :: Show a - => (s -> Either (ParseError t e) a) - -- ^ Parser that takes stream and produces result or error message - -> s -- ^ Input that the parser should fail on - -> Expectation -p `shouldFailOn` s = shouldFail (p s) - --- | Check that a parser succeeds on a given input. --- --- > parse (char 'x') "" `shouldSucceedOn` "x" - -shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => (s -> Either (ParseError t e) a) - -- ^ Parser that takes stream and produces result or error message - -> s -- ^ Input that the parser should succeed on - -> Expectation -p `shouldSucceedOn` s = shouldSucceed (p s) - ----------------------------------------------------------------------------- --- Testing of error messages - --- | Create an expectation that parser should fail producing certain --- 'ParseError'. Use the 'err' function from this module to construct a --- 'ParseError' to compare with. --- --- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x') - -shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -> ParseError t e - -> Expectation -r `shouldFailWith` e = case r of - Left e' -> unless (e == e') . expectationFailure $ - "the parser is expected to fail with:\n" ++ showParseError e ++ - "but it failed with:\n" ++ showParseError e' - Right v -> expectationFailure $ - "the parser is expected to fail, but it parsed: " ++ show v - ----------------------------------------------------------------------------- --- Error message construction - --- $errmsg --- --- When you wish to test error message on failure, the need to construct a --- error message for comparison arises. These helpers allow to construct --- virtually any sort of error message easily. - --- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To --- create source position, two helpers are available: 'posI' and 'posN'. --- @'EC' t e@ is a monoid and can be built from primitives provided by this --- module, see below. --- --- @since 0.3.0 - -err - :: NonEmpty SourcePos -- ^ 'ParseError' position - -> EC t e -- ^ Error components - -> ParseError t e -- ^ Resulting 'ParseError' -err pos (EC u e c) = ParseError pos u e c - --- | Initial source position with empty file name. --- --- @since 0.3.0 - -posI :: NonEmpty SourcePos -posI = initialPos "" :| [] - --- | @posN n s@ returns source position achieved by applying 'updatePos' --- method corresponding to type of stream @s@ @n@ times. --- --- @since 0.3.0 - -posN :: forall s n. (Stream s, Integral n) - => n - -> s - -> NonEmpty SourcePos -posN n see = f (initialPos "") see n :| [] - where - f p s !i = - if i > 0 - then case uncons s of - Nothing -> p - Just (t,s') -> - let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t - in f p' s' (i - 1) - else p - --- | Auxiliary type for construction of 'ParseError's. Note that it's a --- monoid. --- --- @since 0.3.0 - -data EC t e = EC - { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items - , ecExpected :: Set (ErrorItem t) -- ^ Expected items - , _ecCustom :: Set e -- ^ Custom items - } deriving (Eq, Data, Typeable, Generic) - -instance (Ord t, Ord e) => Semigroup (EC t e) where - (EC u0 e0 c0) <> (EC u1 e1 c1) = - EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1) - -instance (Ord t, Ord e) => Monoid (EC t e) where - mempty = EC E.empty E.empty E.empty - mappend = (<>) - --- | Construct an “unexpected token” error component. --- --- @since 0.3.0 - -utok :: (Ord t, Ord e) => t -> EC t e -utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t } - --- | Construct an “unexpected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -utoks :: (Ord t, Ord e) => [t] -> EC t e -utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t } - --- | Construct an “unexpected label” error component. Do not use with empty --- strings (for empty strings it's bottom). --- --- @since 0.3.0 - -ulabel :: (Ord t, Ord e) => String -> EC t e -ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l } - --- | Construct an “unexpected end of input” error component. --- --- @since 0.3.0 - -ueof :: (Ord t, Ord e) => EC t e -ueof = mempty { ecUnexpected = E.singleton EndOfInput } - --- | Construct an “expected token” error component. --- --- @since 0.3.0 - -etok :: (Ord t, Ord e) => t -> EC t e -etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t } - --- | Construct an “expected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -etoks :: (Ord t, Ord e) => [t] -> EC t e -etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t } - --- | Construct an “expected label” error component. Do not use with empty --- strings. --- --- @since 0.3.0 - -elabel :: (Ord t, Ord e) => String -> EC t e -elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l } - --- | Construct an “expected end of input” error component. --- --- @since 0.3.0 - -eeof :: (Ord t, Ord e) => EC t e -eeof = mempty { ecExpected = E.singleton EndOfInput } - --- | Construct a custom error component. --- --- @since 0.3.0 - -cstm :: e -> EC t e -cstm e = EC E.empty E.empty (E.singleton e) - ----------------------------------------------------------------------------- --- Incremental parsing - --- | Check that a parser fails and leaves a certain part of input --- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' --- that support incremental parsing. --- --- > runParser' (many (char 'x') <* eof) (initialState "xxa") --- > `failsLeaving` "a" --- --- See also: 'initialState'. - -failsLeaving :: (Show a, Eq s, Show s, Stream s) - => (State s, Either (ParseError (Token s) e) a) - -- ^ Parser that takes stream and produces result along with actual - -- state information - -> s -- ^ Part of input that should be left unconsumed - -> Expectation -(st,r) `failsLeaving` s = - shouldFail r >> checkUnconsumed s (stateInput st) - --- | Check that a parser succeeds and leaves certain part of input --- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' --- that support incremental parsing. --- --- > runParser' (many (char 'x')) (initialState "xxa") --- > `succeedsLeaving` "a" --- --- See also: 'initialState'. - -succeedsLeaving :: ( ShowToken (Token s) - , ShowErrorComponent e - , Show a - , Eq s - , Show s - , Stream s ) - => (State s, Either (ParseError (Token s) e) a) - -- ^ Parser that takes stream and produces result along with actual - -- state information - -> s -- ^ Part of input that should be left unconsumed - -> Expectation -(st,r) `succeedsLeaving` s = - shouldSucceed r >> checkUnconsumed s (stateInput st) - --- | Given input for parsing, construct initial state for parser (that is, --- with empty file name, default tab width and position at 1 line and 1 --- column). - -initialState :: s -> State s -initialState s = State - { stateInput = s - , statePos = initialPos "" :| [] -#if MIN_VERSION_megaparsec(5,2,0) - , stateTokensProcessed = 0 -#endif - , stateTabWidth = defaultTabWidth } - ----------------------------------------------------------------------------- --- Helpers - --- | Expectation that argument is result of a failed parser. - -shouldFail :: Show a - => Either (ParseError t e) a - -> Expectation -shouldFail r = case r of - Left _ -> return () - Right v -> expectationFailure $ - "the parser is expected to fail, but it parsed: " ++ show v - --- | Expectation that argument is result of a succeeded parser. - -shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -> Expectation -shouldSucceed r = case r of - Left e -> expectationFailure $ - "the parser is expected to succeed, but it failed with:\n" ++ - showParseError e - Right _ -> return () - --- | Compare two streams for equality and in the case of mismatch report it. - -checkUnconsumed :: (Eq s, Show s, Stream s) - => s -- ^ Expected unconsumed input - -> s -- ^ Actual unconsumed input - -> Expectation -checkUnconsumed e a = unless (e == a) . expectationFailure $ - "the parser is expected to leave unconsumed input: " ++ show e ++ - "\nbut it left this: " ++ show a - --- | Render parse error in a way that is suitable for inserting it in a test --- suite report. - -showParseError :: (Ord t, ShowToken t, ShowErrorComponent e) - => ParseError t e -> String -showParseError = unlines . fmap (" " ++) . lines . parseErrorPretty - --- | Make a singleton non-empty list from a value. - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} - --- | Construct appropriate 'ErrorItem' representation for given token --- stream. Empty string produces 'EndOfInput'. - -canonicalizeTokens :: [t] -> ErrorItem t -canonicalizeTokens ts = - case NE.nonEmpty ts of - Nothing -> EndOfInput - Just xs -> Tokens xs diff --git a/tests/Test/Hspec/Megaparsec/AdHoc.hs b/tests/Test/Hspec/Megaparsec/AdHoc.hs deleted file mode 100644 --- a/tests/Test/Hspec/Megaparsec/AdHoc.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Test.Hspec.Megaparsec.AdHoc - ( -- * Helpers to run parsers - prs - , prs' - , prs_ - , grs - , grs' - -- * Working with source position - , updatePosString - , pos1 - , nes - -- * Other - , abcRow - , toFirstMismatch ) -where - -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Trans.Identity -import Data.Foldable (foldl') -import Data.List.NonEmpty (NonEmpty (..)) -import Test.Hspec -import Test.Hspec.Megaparsec -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import Text.Megaparsec.Prim -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.State.Lazy as L -import qualified Control.Monad.State.Strict as S -import qualified Control.Monad.Writer.Lazy as L -import qualified Control.Monad.Writer.Strict as S - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - ----------------------------------------------------------------------------- --- Helpers to run parsers - --- | Apply parser to given input. This is a specialized version of 'parse' --- that assumes empty file name. - -prs - :: Parsec Dec String a -- ^ Parser to run - -> String -- ^ Input for the parser - -> Either (ParseError Char Dec) a -- ^ Result of parsing -prs p = parse p "" -{-# INLINE prs #-} - --- | Just like 'prs', but allows to inspect final state of the parser. - -prs' - :: Parsec Dec String a -- ^ Parser to run - -> String -- ^ Input for the parser - -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing -prs' p s = runParser' p (initialState s) -{-# INLINE prs' #-} - --- | Just like 'prs', but forces the parser to consume all input by adding --- 'eof': --- --- > prs_ p = parse (p <* eof) "" - -prs_ - :: Parsec Dec String a -- ^ Parser to run - -> String -- ^ Input for the parser - -> Either (ParseError Char Dec) a -- ^ Result of parsing -prs_ p = parse (p <* eof) "" -{-# INLINE prs_ #-} - --- | Just like 'prs', but interprets given parser as various monads (tries --- all supported monads transformers in turn). - -grs - :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run - -> String -- ^ Input for the parser - -> (Either (ParseError Char Dec) a -> Expectation) - -- ^ How to check result of parsing - -> Expectation -grs p s r = do - r (prs p s) - r (prs (runIdentityT p) s) - r (prs (runReaderT p ()) s) - r (prs (L.evalStateT p ()) s) - r (prs (S.evalStateT p ()) s) - r (prs (evalWriterTL p) s) - r (prs (evalWriterTS p) s) - r (prs (evalRWSTL p) s) - r (prs (evalRWSTS p) s) - --- | 'grs'' to 'grs' as 'prs'' to 'prs'. - -grs' - :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run - -> String -- ^ Input for the parser - -> ((State String, Either (ParseError Char Dec) a) -> Expectation) - -- ^ How to check result of parsing - -> Expectation -grs' p s r = do - r (prs' p s) - r (prs' (runIdentityT p) s) - r (prs' (runReaderT p ()) s) - r (prs' (L.evalStateT p ()) s) - r (prs' (S.evalStateT p ()) s) - r (prs' (evalWriterTL p) s) - r (prs' (evalWriterTS p) s) - r (prs' (evalRWSTL p) s) - r (prs' (evalRWSTS p) s) - -evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a -evalWriterTL = liftM fst . L.runWriterT -evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a -evalWriterTS = liftM fst . S.runWriterT - -evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a -evalRWSTL m = do - (a,_,_) <- L.runRWST m () () - return a - -evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a -evalRWSTS m = do - (a,_,_) <- S.runRWST m () () - return a - ----------------------------------------------------------------------------- --- Working with source position - --- | A helper function that is used to advance 'SourcePos' given a 'String'. - -updatePosString - :: Pos -- ^ Tab width - -> SourcePos -- ^ Initial position - -> String -- ^ 'String' — collection of tokens to process - -> SourcePos -- ^ Final position -updatePosString w = foldl' f - where f p t = snd (defaultUpdatePos w p t) - --- | Position with minimal value. - -pos1 :: Pos -pos1 = unsafePos 1 - --- | Make a singleton non-empty list from a value. - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} - ----------------------------------------------------------------------------- --- Other - --- | @abcRow a b c@ generates string consisting of character “a” repeated --- @a@ times, character “b” repeated @b@ times, and character “c” repeated --- @c@ times. - -abcRow :: Int -> Int -> Int -> String -abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' - --- | Given a comparing function, get prefix of one string till first --- mismatch with another string (including first mismatching character). - -toFirstMismatch - :: (Char -> Char -> Bool) -- ^ Comparing function - -> String -- ^ First string - -> String -- ^ Second string - -> String -- ^ Resulting prefix -toFirstMismatch f str s = take (n + 1) s - where n = length (takeWhile (uncurry f) (zip str s)) diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/CharSpec.hs +++ /dev/null @@ -1,426 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.Megaparsec.CharSpec (spec) where - -import Control.Monad -import Data.Char -import Data.List (partition, isPrefixOf) -import Data.Monoid ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Char -import Text.Megaparsec.Error -import Text.Megaparsec.Prim - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -instance Arbitrary GeneralCategory where - arbitrary = elements [minBound..maxBound] - -spec :: Spec -spec = do - - describe "newline" $ - checkStrLit "newline" "\n" (pure <$> newline) - - describe "csrf" $ - checkStrLit "crlf newline" "\r\n" crlf - - describe "eol" $ do - context "when stream begins with a newline" $ - it "succeeds returning the newline" $ - property $ \s -> do - let s' = '\n' : s - prs eol s' `shouldParse` "\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with CRLF sequence" $ - it "parses the CRLF sequence" $ - property $ \s -> do - let s' = '\r' : '\n' : s - prs eol s' `shouldParse` "\r\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with '\\r', but it's not followed by '\\n'" $ - it "signals correct parse error" $ - property $ \ch -> ch /= '\n' ==> do - let s = ['\r',ch] - prs eol s `shouldFailWith` err posI - (utoks s <> utok '\r' <> elabel "end of line") - context "when input stream is '\\r'" $ - it "signals correct parse error" $ - prs eol "\r" `shouldFailWith` err posI - (utok '\r' <> elabel "end of line") - context "when stream does not begin with newline or CRLF sequence" $ - it "signals correct parse error" $ - property $ \ch s -> (ch `notElem` "\r\n") ==> do - let s' = ch : s - prs eol s' `shouldFailWith` err posI - (utok ch <> elabel "end of line") - context "when stream is empty" $ - it "signals correct parse error" $ - prs eol "" `shouldFailWith` err posI - (ueof <> elabel "end of line") - - describe "tab" $ - checkStrLit "tab" "\t" (pure <$> tab) - - describe "space" $ - it "consumes it up to first non-space character" $ - property $ \s -> do - let (s0,s1) = partition isSpace s - s' = s0 ++ s1 - prs space s' `shouldParse` () - prs' space s' `succeedsLeaving` s1 - - describe "controlChar" $ - checkCharPred "control character" isControl controlChar - - describe "spaceChar" $ - checkCharRange "white space" " \160\t\n\r\f\v" spaceChar - - describe "upperChar" $ - checkCharPred "uppercase letter" isUpper upperChar - - describe "lowerChar" $ - checkCharPred "lowercase letter" isLower lowerChar - - describe "letterChar" $ - checkCharPred "letter" isAlpha letterChar - - describe "alphaNumChar" $ - checkCharPred "alphanumeric character" isAlphaNum alphaNumChar - - describe "printChar" $ - checkCharPred "printable character" isPrint printChar - - describe "digitChar" $ - checkCharRange "digit" ['0'..'9'] digitChar - - describe "octDigitChar" $ - checkCharRange "octal digit" ['0'..'7'] octDigitChar - - describe "hexDigitChar" $ - checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar - - describe "markChar" $ -#if MIN_VERSION_base(4,9,0) - checkCharRange "mark character" "\71229\7398" markChar -#else - checkCharRange "mark character" "" markChar -#endif - - describe "numberChar" $ - let xs = "\185\178\179\188\189\190" ++ ['0'..'9'] - in checkCharRange "numeric character" xs numberChar - - describe "punctuationChar" $ - checkCharPred "punctuation" isPunctuation punctuationChar - - describe "symbolChar" $ -#if MIN_VERSION_base(4,8,0) - checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar -#else - checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar -#endif - describe "separatorChar" $ - checkCharRange "separator" " \160" separatorChar - - describe "asciiChar" $ - checkCharPred "ASCII character" isAscii asciiChar - - describe "latin1Char" $ do - context "when stream begins with Latin-1 character" $ - it "parses the Latin-1 character" $ - property $ \ch s -> isLatin1 ch ==> do - let s' = ch : s - prs latin1Char s' `shouldParse` ch - prs' latin1Char s' `succeedsLeaving` s - context "when stream does not begin with Latin-1 character" $ - it "signals correct parse error" $ do - prs latin1Char "б" `shouldFailWith` - err posI (utok 'б' <> elabel "Latin-1 character") - prs' latin1Char "в" `failsLeaving` "в" - context "when stream is empty" $ - it "signals correct parse error" $ - prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character") - - describe "charCategory" $ do - context "when parser corresponding to general category of next char is used" $ - it "succeeds" $ - property $ \ch s -> do - let s' = ch : s - g = generalCategory ch - prs (charCategory g) s' `shouldParse` ch - prs' (charCategory g) s' `succeedsLeaving` s - context "when parser's category does not match next character's category" $ - it "fails" $ - property $ \g ch s -> (generalCategory ch /= g) ==> do - let s' = ch : s - prs (charCategory g) s' `shouldFailWith` - err posI (utok ch <> elabel (categoryName g)) - prs' (charCategory g) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \g -> - prs (charCategory g) "" `shouldFailWith` - err posI (ueof <> elabel (categoryName g)) - - describe "char" $ do - context "when stream begins with the character specified as argument" $ - it "parses the character" $ - property $ \ch s -> do - let s' = ch : s - prs (char ch) s' `shouldParse` ch - prs' (char ch) s' `succeedsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch ch' s -> ch /= ch' ==> do - let s' = ch' : s - prs (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch) - prs' (char ch) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> - prs (char ch) "" `shouldFailWith` err posI (ueof <> etok ch) - - describe "char'" $ do - context "when stream begins with the character specified as argument" $ - it "parses the character" $ - property $ \ch s -> do - let sl = toLower ch : s - su = toUpper ch : s - prs (char' ch) sl `shouldParse` toLower ch - prs (char' ch) su `shouldParse` toUpper ch - prs' (char' ch) sl `succeedsLeaving` s - prs' (char' ch) su `succeedsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch ch' s -> toLower ch /= toLower ch' ==> do - let s' = ch' : s - ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) - prs (char' ch) s' `shouldFailWith` err posI ms - prs' (char' ch) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> do - let ms = ueof <> etok (toLower ch) <> etok (toUpper ch) - prs (char' ch) "" `shouldFailWith` err posI ms - - describe "anyChar" $ do - context "when stream is not empty" $ - it "succeeds consuming next character in the stream" $ - property $ \ch s -> do - let s' = ch : s - prs anyChar s' `shouldParse` ch - prs' anyChar s' `succeedsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character") - - describe "oneOf" $ do - context "when stream begins with one of specified characters" $ - it "parses the character" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - s' = ch : s - prs (oneOf chs) s' `shouldParse` ch - prs' (oneOf chs) s' `succeedsLeaving` s - context "when stream does not begin with any of specified characters" $ - it "signals correct parse error" $ - property $ \chs ch s -> ch `notElem` (chs :: String) ==> do - let s' = ch : s - prs (oneOf chs) s' `shouldFailWith` err posI (utok ch) - prs' (oneOf chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "oneOf'" $ do - context "when stream begins with one of specified characters" $ - it "parses the character" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - sl = toLower ch : s - su = toUpper ch : s - prs (oneOf' chs) sl `shouldParse` toLower ch - prs (oneOf' chs) su `shouldParse` toUpper ch - prs' (oneOf' chs) sl `succeedsLeaving` s - prs' (oneOf' chs) su `succeedsLeaving` s - context "when stream does not begin with any of specified characters" $ - it "signals correct parse error" $ - property $ \chs ch s -> ch `notElemi` (chs :: String) ==> do - let s' = ch : s - prs (oneOf' chs) s' `shouldFailWith` err posI (utok ch) - prs' (oneOf' chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (oneOf' (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "noneOf" $ do - context "when stream does not begin with any of specified characters" $ - it "parses the character" $ - property $ \chs ch s -> ch `notElem` (chs :: String) ==> do - let s' = ch : s - prs (noneOf chs) s' `shouldParse` ch - prs' (noneOf chs) s' `succeedsLeaving` s - context "when stream begins with one of specified characters" $ - it "signals correct parse error" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - s' = ch : s - prs (noneOf chs) s' `shouldFailWith` err posI (utok ch) - prs' (noneOf chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "noneOf'" $ do - context "when stream does not begin with any of specified characters" $ - it "parses the character" $ - property $ \chs ch s -> ch `notElemi` (chs :: String) ==> do - let sl = toLower ch : s - su = toUpper ch : s - prs (noneOf' chs) sl `shouldParse` toLower ch - prs (noneOf' chs) su `shouldParse` toUpper ch - prs' (noneOf' chs) sl `succeedsLeaving` s - prs' (noneOf' chs) su `succeedsLeaving` s - context "when stream begins with one of specified characters" $ - it "signals correct parse error" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - s' = ch : s - prs (noneOf' chs) s' `shouldFailWith` err posI (utok ch) - prs' (noneOf' chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (noneOf' (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "string" $ do - context "when stream is prefixed with given string" $ - it "parses the string" $ - property $ \str s -> do - let s' = str ++ s - prs (string str) s' `shouldParse` str - prs' (string str) s' `succeedsLeaving` s - context "when stream is not prefixed with given string" $ - it "signals correct parse error" $ - property $ \str s -> not (str `isPrefixOf` s) ==> do - let n = length (takeWhile (uncurry (==)) (zip str s)) + 1 - common = take n s - prs (string str) s `shouldFailWith` err posI (utoks common <> etoks str) - - describe "string'" $ do - context "when stream is prefixed with given string" $ - it "parses the string" $ - property $ \str s -> - forAll (fuzzyCase str) $ \str' -> do - let s' = str' ++ s - prs (string' str) s' `shouldParse` str' - prs' (string' str) s' `succeedsLeaving` s - context "when stream is not prefixed with given string" $ - it "signals correct parse error" $ - property $ \str s -> not (str `isPrefixOfI` s) ==> do - let n = length (takeWhile (uncurry casei) (zip str s)) + 1 - common = take n s - prs (string' str) s `shouldFailWith` err posI (utoks common <> etoks str) - ----------------------------------------------------------------------------- --- Helpers - -checkStrLit :: String -> String -> Parsec Dec String String -> SpecWith () -checkStrLit name ts p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \s -> do - let s' = ts ++ s - prs p s' `shouldParse` ts - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> ch /= head ts ==> do - let s' = ch : s - prs p s' `shouldFailWith` err posI (utok ch <> etoks ts) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> etoks ts) - -checkCharPred :: String -> (Char -> Bool) -> Parsec Dec String Char -> SpecWith () -checkCharPred name f p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \ch s -> f ch ==> do - let s' = ch : s - prs p s' `shouldParse` ch - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> not (f ch) ==> do - let s' = ch : s - prs p s' `shouldFailWith` err posI (utok ch <> elabel name) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - -checkCharRange :: String -> String -> Parsec Dec String Char -> SpecWith () -checkCharRange name tchs p = do - forM_ tchs $ \tch -> - context ("when stream begins with " ++ showTokens (nes tch)) $ - it ("parses the " ++ showTokens (nes tch)) $ - property $ \s -> do - let s' = tch : s - prs p s' `shouldParse` tch - prs' p s' `succeedsLeaving` s - -- context ("when stream does not begin with " ++ name) $ - -- it "signals correct parse error" $ - -- property $ \ch s -> ch `notElem` tchs ==> do - -- let s' = ch : s - -- prs p s' `shouldFailWith` err posI (utok ch <> elabel name) - -- prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - --- | Randomly change the case in the given string. - -fuzzyCase :: String -> Gen String -fuzzyCase s = zipWith f s <$> vector (length s) - where f k True = if isLower k then toUpper k else toLower k - f k False = k - --- | Case-insensitive equality test for characters. - -casei :: Char -> Char -> Bool -casei x y = toUpper x == toUpper y - --- | Case-insensitive 'elem'. - -elemi :: Char -> String -> Bool -elemi c = any (casei c) - --- | Case-insensitive 'notElem'. - -notElemi :: Char -> String -> Bool -notElemi c = not . elemi c - --- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff --- the first list is a prefix of the second with case-insensitive --- comparison. - -isPrefixOfI :: String -> String -> Bool -isPrefixOfI [] _ = True -isPrefixOfI _ [] = False -isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys diff --git a/tests/Text/Megaparsec/CombinatorSpec.hs b/tests/Text/Megaparsec/CombinatorSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/CombinatorSpec.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -module Text.Megaparsec.CombinatorSpec (spec) where - -import Control.Applicative -import Data.Char (isLetter, isDigit) -import Data.List (intersperse) -import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) -import Data.Monoid -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Char -import Text.Megaparsec.Combinator - -spec :: Spec -spec = do - - describe "between" . it "works" . property $ \pre c n' post -> do - let p = between (string pre) (string post) (many (char c)) - n = getNonNegative n' - b = length (takeWhile (== c) post) - z = replicate n c - s = pre ++ z ++ post - if b > 0 - then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s) - ( etoks post <> etok c <> - (if length post == b then ueof else utoks [post !! b]) ) - else prs_ p s `shouldParse` z - - describe "choice" . it "works" . property $ \cs' s' -> do - let cs = getNonEmpty cs' - p = choice (char <$> cs) - s = [s'] - if s' `elem` cs - then prs_ p s `shouldParse` s' - else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs)) - - describe "count" . it "works" . property $ \n x' -> do - let x = getNonNegative x' - p = count n (char 'x') - p' = count' n n (char 'x') - s = replicate x 'x' - prs_ p s `shouldBe` prs_ p' s - - describe "count'" . it "works" . property $ \m n x' -> do - let x = getNonNegative x' - p = count' m n (char 'x') - s = replicate x 'x' - if | n <= 0 || m > n -> - if x == 0 - then prs_ p s `shouldParse` "" - else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof) - | m <= x && x <= n -> - prs_ p s `shouldParse` s - | x < m -> - prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x') - | otherwise -> - prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof) - - describe "eitherP" . it "works" . property $ \ch -> do - let p = eitherP letterChar digitChar - s = pure ch - if | isLetter ch -> prs_ p s `shouldParse` Left ch - | isDigit ch -> prs_ p s `shouldParse` Right ch - | otherwise -> prs_ p s `shouldFailWith` - err posI (utok ch <> elabel "letter" <> elabel "digit") - - describe "endBy" . it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof) - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else eeof) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - - describe "endBy1" . it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a') - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else mempty) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - - describe "manyTill" . it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if c == 0 - then prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - - describe "someTill" . it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> someTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if | null s -> - prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter") - | c == 0 -> - prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - | s == "c" -> - prs_ p s `shouldFailWith` err - (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter") - | head s == 'c' -> - prs_ p s `shouldParse` ("c", drop 2 s) - | otherwise -> - let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - - describe "option" . it "works" . property $ \d a s -> do - let p = option d (string a) - p' = fromMaybe d <$> optional (string a) - prs_ p s `shouldBe` prs_ p' s - - describe "sepBy" . it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` replicate n 'a' - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI - (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) - (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) - (utok c <> etok '-' <> eeof) - - describe "sepBy1" . it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` replicate n 'a' - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - - describe "sepEndBy" . it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` a - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - - describe "sepEndBy1" . it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy1 (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` a - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - - describe "skipMany" . it "works" . property $ \c n' a -> do - let p = skipMany (char c) *> string a - n = getNonNegative n' - p' = many (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipSome" . it "works" . property $ \c n' a -> do - let p = skipSome (char c) *> string a - n = getNonNegative n' - p' = some (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - ----------------------------------------------------------------------------- --- Helpers - -g :: Int -> Int -g x = x + if x > 0 then x - 1 else 0 diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/ErrorSpec.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.Megaparsec.ErrorSpec (spec) where - -import Data.Char (isControl, isSpace) -import Data.Function (on) -import Data.List (isInfixOf, isSuffixOf) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid -import Data.Set (Set) -import Test.Hspec -import Test.QuickCheck -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as S -import qualified Data.Set as E - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable, all) -import Prelude hiding (all) -#else -import Control.Exception (Exception (..)) -#endif - -type PE = ParseError Char Dec - -spec :: Spec -spec = do - - describe "Semigroup instance of ParseError" $ - it "associativity" $ - property $ \x y z -> - (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE) - - describe "Monoid instance of ParseError" $ do - it "left identity" $ - property $ \x -> - mempty <> x === (x :: PE) - it "right identity" $ - property $ \x -> - x <> mempty === (x :: PE) - it "associativity" $ - property $ \x y z -> - (x <> y) <> z === (x <> (y <> z) :: PE) - - describe "Read and Show instances of ParseError" $ - it "printed representation of ParseError can be read back" $ - property $ \x -> - read (show x) === (x :: PE) - - describe "error merging with (<>)" $ do - it "selects greater source position" $ - property $ \x y -> - errorPos (x <> y :: PE) === max (errorPos x) (errorPos y) - it "merges unexpected items correctly" $ - property (checkMergedItems errorUnexpected) - it "merges expected items correctly" $ - property (checkMergedItems errorExpected) - it "merges custom items correctly" $ - property (checkMergedItems errorCustom) - - describe "showTokens (Char instance)" $ do - let f x y = showTokens (NE.fromList x) `shouldBe` y - it "shows CRLF newline correctly" - (f "\r\n" "crlf newline") - it "shows null byte correctly" - (f "\NUL" "null (control character)") - it "shows start of heading correctly" - (f "\SOH" "start of heading (control character)") - it "shows start of text correctly" - (f "\STX" "start of text (control character)") - it "shows end of text correctly" - (f "\ETX" "end of text (control character)") - it "shows end of transmission correctly" - (f "\EOT" "end of transmission (control character)") - it "shows enquiry correctly" - (f "\ENQ" "enquiry (control character)") - it "shows acknowledge correctly" - (f "\ACK" "acknowledge (control character)") - it "shows bell correctly" - (f "\BEL" "bell (control character)") - it "shows backspace correctly" - (f "\BS" "backspace") - it "shows tab correctly" - (f "\t" "tab") - it "shows newline correctly" - (f "\n" "newline") - it "shows vertical tab correctly" - (f "\v" "vertical tab") - it "shows form feed correctly" - (f "\f" "form feed (control character)") - it "shows carriage return correctly" - (f "\r" "carriage return") - it "shows shift out correctly" - (f "\SO" "shift out (control character)") - it "shows shift in correctly" - (f "\SI" "shift in (control character)") - it "shows data link escape correctly" - (f "\DLE" "data link escape (control character)") - it "shows device control one correctly" - (f "\DC1" "device control one (control character)") - it "shows device control two correctly" - (f "\DC2" "device control two (control character)") - it "shows device control three correctly" - (f "\DC3" "device control three (control character)") - it "shows device control four correctly" - (f "\DC4" "device control four (control character)") - it "shows negative acknowledge correctly" - (f "\NAK" "negative acknowledge (control character)") - it "shows synchronous idle correctly" - (f "\SYN" "synchronous idle (control character)") - it "shows end of transmission block correctly" - (f "\ETB" "end of transmission block (control character)") - it "shows cancel correctly" - (f "\CAN" "cancel (control character)") - it "shows end of medium correctly" - (f "\EM" "end of medium (control character)") - it "shows substitute correctly" - (f "\SUB" "substitute (control character)") - it "shows escape correctly" - (f "\ESC" "escape (control character)") - it "shows file separator correctly" - (f "\FS" "file separator (control character)") - it "shows group separator correctly" - (f "\GS" "group separator (control character)") - it "shows record separator correctly" - (f "\RS" "record separator (control character)") - it "shows unit separator correctly" - (f "\US" "unit separator (control character)") - it "shows delete correctly" - (f "\DEL" "delete (control character)") - it "shows space correctly" - (f " " "space") - it "shows non-breaking space correctly" - (f "\160" "non-breaking space") - it "shows other single characters in single quotes" $ - property $ \ch -> - not (isControl ch) && not (isSpace ch) ==> - showTokens (ch :| []) === ['\'',ch,'\''] - it "shows strings in double quotes" $ - property $ \str -> - (length str > 1) && (str /= "\r\n") ==> - showTokens (NE.fromList str) === ("\"" ++ str ++"\"") - - describe "parseErrorPretty" $ do - it "shows unknown ParseError correctly" $ - parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n" - it "result always ends with a newline" $ - property $ \x -> - parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`) - it "result contains representation of source pos stack" $ - property (contains errorPos sourcePosPretty) - it "result contains representation of unexpected items" $ - property (contains errorUnexpected showErrorComponent) - it "result contains representation of expected items" $ - property (contains errorExpected showErrorComponent) - it "result contains representation of custom items" $ - property (contains errorCustom showErrorComponent) - - describe "sourcePosStackPretty" $ - it "result never ends with a newline " $ - property $ \x -> - let pos = errorPos (x :: PE) - in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`) - - describe "parseErrorTextPretty" $ do - it "shows unknown ParseError correctly" $ - parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n" - it "result always ends with a newline" $ - property $ \x -> - parseErrorTextPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`) - -#if MIN_VERSION_base(4,8,0) - describe "displayException" $ - it "produces the same result as parseErrorPretty" $ - property $ \x -> - displayException x `shouldBe` parseErrorPretty (x :: PE) -#endif - ----------------------------------------------------------------------------- --- Helpers - -checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property -checkMergedItems f e1 e2 = f (e1 <> e2) === r - where r = case (compare `on` errorPos) e1 e2 of - LT -> f e2 - EQ -> (E.union `on` f) e1 e2 - GT -> f e1 - -contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property -contains g r e = property (all f (g e)) - where rendered = parseErrorPretty e - f x = r x `isInfixOf` rendered diff --git a/tests/Text/Megaparsec/ExprSpec.hs b/tests/Text/Megaparsec/ExprSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/ExprSpec.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module Text.Megaparsec.ExprSpec (spec) where - -import Control.Applicative (some, (<|>)) -import Data.Monoid ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Char -import Text.Megaparsec.Combinator -import Text.Megaparsec.Expr -import Text.Megaparsec.Prim - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) -#endif - -spec :: Spec -spec = - describe "makeExprParser" $ do - context "when given valid rendered AST" $ - it "can parse it back" $ - property $ \node -> do - let s = showNode node - prs expr s `shouldParse` node - prs' expr s `succeedsLeaving` "" - context "when stream in empty" $ - it "signals correct parse error" $ - prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term") - context "when term is missing" $ - it "signals correct parse error" $ do - let p = expr <* eof - n = 1 :: Integer - prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term") - prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term") - prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term") - context "operator is missing" $ - it "signals correct parse error" $ - property $ \a b -> do - let p = expr <* eof - a' = inParens a - n = length a' + 1 - s = a' ++ " " ++ inParens b - c = s !! n - if c == '-' - then prs p s `shouldParse` Sub a b - else prs p s `shouldFailWith` - err (posN n s) (utok c <> eeof <> elabel "operator") - --- Algebraic structures to build abstract syntax tree of our expression. - -data Node - = Val Integer -- ^ literal value - | Neg Node -- ^ negation (prefix unary) - | Fac Node -- ^ factorial (postfix unary) - | Mod Node Node -- ^ modulo - | Sum Node Node -- ^ summation (addition) - | Sub Node Node -- ^ subtraction - | Pro Node Node -- ^ product - | Div Node Node -- ^ division - | Exp Node Node -- ^ exponentiation - deriving (Eq, Show) - -instance Enum Node where - fromEnum (Val _) = 0 - fromEnum (Neg _) = 0 - fromEnum (Fac _) = 0 - fromEnum (Mod _ _) = 0 - fromEnum (Exp _ _) = 1 - fromEnum (Pro _ _) = 2 - fromEnum (Div _ _) = 2 - fromEnum (Sum _ _) = 3 - fromEnum (Sub _ _) = 3 - toEnum _ = error "Oops!" - -instance Ord Node where - x `compare` y = fromEnum x `compare` fromEnum y - -showNode :: Node -> String -showNode (Val x) = show x -showNode n@(Neg x) = "-" ++ showGT n x -showNode n@(Fac x) = showGT n x ++ "!" -showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y -showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y -showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y -showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y -showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y -showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y - -showGT :: Node -> Node -> String -showGT parent node = (if node > parent then showCmp else showNode) node - -showGE :: Node -> Node -> String -showGE parent node = (if node >= parent then showCmp else showNode) node - -showCmp :: Node -> String -showCmp node = (if fromEnum node == 0 then showNode else inParens) node - -inParens :: Node -> String -inParens x = "(" ++ showNode x ++ ")" - -instance Arbitrary Node where - arbitrary = sized arbitraryN0 - -arbitraryN0 :: Int -> Gen Node -arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf) - , (9, arbitraryN1 n) ] - where leaf = arbitraryN1 (n `div` 2) - -arbitraryN1 :: Int -> Gen Node -arbitraryN1 n = - frequency [ (1, Neg <$> arbitraryN2 n) - , (1, Fac <$> arbitraryN2 n) - , (7, arbitraryN2 n)] - -arbitraryN2 :: Int -> Gen Node -arbitraryN2 0 = Val . getNonNegative <$> arbitrary -arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf - where leaf = arbitraryN0 (n `div` 2) - --- Some helpers are put here since we don't want to depend on --- "Text.Megaparsec.Lexer". - -lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a -lexeme p = p <* hidden space - -symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String -symbol = lexeme . string - -parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a -parens = between (symbol "(") (symbol ")") - -integer :: (MonadParsec e s m, Token s ~ Char) => m Integer -integer = lexeme (read <$> some digitChar "integer") - --- Here we use a table of operators that makes use of all features of --- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex --- but valid expressions and render them to get their textual --- representation. - -expr :: (MonadParsec e s m, Token s ~ Char) => m Node -expr = makeExprParser term table - -term :: (MonadParsec e s m, Token s ~ Char) => m Node -term = parens expr <|> (Val <$> integer) "term" - -table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]] -table = [ [ Prefix (symbol "-" *> pure Neg) - , Postfix (symbol "!" *> pure Fac) - , InfixN (symbol "%" *> pure Mod) ] - , [ InfixR (symbol "^" *> pure Exp) ] - , [ InfixL (symbol "*" *> pure Pro) - , InfixL (symbol "/" *> pure Div) ] - , [ InfixL (symbol "+" *> pure Sum) - , InfixL (symbol "-" *> pure Sub)] ] diff --git a/tests/Text/Megaparsec/LexerSpec.hs b/tests/Text/Megaparsec/LexerSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/LexerSpec.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -module Text.Megaparsec.LexerSpec (spec) where - -import Control.Applicative -import Control.Monad (void) -import Data.Char hiding (ord) -import Data.List (isInfixOf) -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Scientific (fromFloatDigits) -import Numeric (showInt, showHex, showOct) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Error -import Text.Megaparsec.Lexer -import Text.Megaparsec.Pos -import Text.Megaparsec.Prim -import Text.Megaparsec.String -import qualified Text.Megaparsec.Char as C - -spec :: Spec -spec = do - - describe "space" $ - it "consumes any sort of white space" $ - property $ forAll mkWhiteSpace $ \s -> do - prs scn s `shouldParse` () - prs' scn s `succeedsLeaving` "" - - describe "symbol" $ - context "when stream begins with the symbol" $ - it "parses the symbol and trailing whitespace" $ - property $ forAll mkSymbol $ \s -> do - let p = symbol scn y - y = takeWhile (not . isSpace) s - prs p s `shouldParse` y - prs' p s `succeedsLeaving` "" - - describe "symbol'" $ - context "when stream begins with the symbol" $ - it "parses the symbol and trailing whitespace" $ - property $ forAll mkSymbol $ \s -> do - let p = symbol' scn (toUpper <$> y) - y = takeWhile (not . isSpace) s - prs p s `shouldParse` y - prs' p s `succeedsLeaving` "" - - describe "skipLineComment" $ - context "when there is no newline at the end of line" $ - it "is picked up successfully" $ do - let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof - s = " // this line comment doesn't have a newline at the end " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - - describe "skipBlockCommentNested" $ - context "when it runs into nested block comments" $ - it "parses them all right" $ do - let p = space (void C.spaceChar) empty - (skipBlockCommentNested "/*" "*/") <* eof - s = " /* foo bar /* baz */ quux */ " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - - describe "indentLevel" $ - it "returns current indentation level (column)" $ - property $ \pos -> do - let p = setPosition pos *> indentLevel - prs p "" `shouldParse` sourceColumn pos - - describe "incorrectIndent" $ - it "signals correct parse error" $ - property $ \ord ref actual -> do - let p :: Parser () - p = incorrectIndent ord ref actual - prs p "" `shouldFailWith` err posI (ii ord ref actual) - - describe "indentGuard" $ - it "works as intended" $ - property $ \n -> do - let mki = mkIndent sbla (getSmall $ getNonNegative n) - forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do - let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) - fragments = [l0,l1,l2] - g x = sum (length <$> take x fragments) - s = concat fragments - p = ip GT pos1 >>= - \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn - ip = indentGuard scn - sp = void (symbol sc sbla <* C.eol) - if | col0 <= pos1 -> - prs p s `shouldFailWith` err posI (ii GT pos1 col0) - | col1 /= col0 -> - prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1) - | col2 <= col0 -> - prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) - | otherwise -> - prs p s `shouldParse` () - - describe "nonIdented" $ - it "works as intended" $ - property $ forAll (mkIndent sbla 0) $ \s -> do - let p = nonIndented scn (symbol scn sbla) - i = getIndent s - if i == 0 - then prs p s `shouldParse` sbla - else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s)) - - describe "indentBlock" $ do - it "works as indented" $ - property $ \mn'' -> do - let mkBlock = do - l0 <- mkIndent sbla 0 - l1 <- mkIndent sblb ib - l2 <- mkIndent sblc (ib + 2) - l3 <- mkIndent sblb ib - l4 <- mkIndent' sblc (ib + 2) - return (l0,l1,l2,l3,l4) - ib = fromMaybe 2 mn' - mn' = getSmall . getPositive <$> mn'' - mn = unsafePos . fromIntegral <$> mn' - forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do - let (col0, col1, col2, col3, col4) = - (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4) - fragments = [l0,l1,l2,l3,l4] - g x = sum (length <$> take x fragments) - s = concat fragments - p = lvla <* eof - lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla - lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb - lvlc = indentBlock scn $ IndentNone sblc <$ b sblc - b = symbol sc - l x = return . (x,) - ib' = unsafePos (fromIntegral ib) - if | col1 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof) - | isJust mn && col1 /= ib' -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1) - | col2 <= col1 -> prs p s `shouldFailWith` - err (posN (getIndent l2 + g 2) s) (ii GT col1 col2) - | col3 == col2 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc <> eeof) - | col3 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof) - | col3 < col1 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3) - | col3 > col1 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3) - | col4 <= col3 -> prs p s `shouldFailWith` - err (posN (getIndent l4 + g 4) s) (ii GT col3 col4) - | otherwise -> prs p s `shouldParse` - (sbla, [(sblb, [sblc]), (sblb, [sblc])]) - it "IndentMany works as intended (newline at the end)" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs p s `shouldParse` (sbla, []) - prs' p s `succeedsLeaving` "" - it "IndentMany works as intended (eof)" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs p s `shouldParse` (sbla, []) - prs' p s `succeedsLeaving` "" - it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - s = "aaa\n bbb\n " - prs p s `shouldParse` (sbla, [sblb]) - prs' p s `succeedsLeaving` "" - it "works with many and both IndentMany and IndentNone" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do - let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - p2 = indentBlock scn $ IndentNone sbla <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs (many p1) s `shouldParse` [(sbla, [])] - prs (many p2) s `shouldParse` [sbla] - prs' (many p1) s `succeedsLeaving` "" - prs' (many p2) s `succeedsLeaving` "" - - describe "lineFold" $ - it "works as intended" $ - property $ do - let mkFold = do - l0 <- mkInterspace sbla 0 - l1 <- mkInterspace sblb 1 - l2 <- mkInterspace sblc 1 - return (l0,l1,l2) - forAll mkFold $ \(l0,l1,l2) -> do - let p = lineFold scn $ \sc' -> do - a <- symbol sc' sbla - b <- symbol sc' sblb - c <- symbol scn sblc - return (a, b, c) - getEnd x = last x == '\n' - fragments = [l0,l1,l2] - g x = sum (length <$> take x fragments) - s = concat fragments - (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) - (end0, end1) = (getEnd l0, getEnd l1) - if | end0 && col1 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (ii GT col0 col1) - | end1 && col2 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) - | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) - - describe "charLiteral" $ do - context "when stream begins with a literal character" $ - it "parses it" $ - property $ \ch -> do - let p = charLiteral - s = showLitChar ch "" - prs p s `shouldParse` ch - prs' p s `succeedsLeaving` "" - context "when stream does not begin with a literal character" $ - it "signals correct parse error" $ do - let p = charLiteral - s = "\\" - prs p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character") - prs' p s `failsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ do - let p = charLiteral - prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character") - - describe "integer" $ do - context "when stream begins with decimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = integer - n = getNonNegative n' - s = showInt n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with decimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = integer - s = a : as - prs p s `shouldFailWith` err posI (utok a <> elabel "integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs integer "" `shouldFailWith` - err posI (ueof <> elabel "integer") - - describe "decimal" $ do - context "when stream begins with decimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = decimal - n = getNonNegative n' - s = showInt n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with decimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = decimal - s = a : as - prs p s `shouldFailWith` err posI (utok a <> elabel "decimal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs decimal "" `shouldFailWith` - err posI (ueof <> elabel "decimal integer") - - describe "hexadecimal" $ do - context "when stream begins with hexadecimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = hexadecimal - n = getNonNegative n' - s = showHex n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with hexadecimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isHexDigit a) ==> do - let p = hexadecimal - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "hexadecimal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs hexadecimal "" `shouldFailWith` - err posI (ueof <> elabel "hexadecimal integer") - - describe "octal" $ do - context "when stream begins with octal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = octal - n = getNonNegative n' - s = showOct n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with octal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isOctDigit a) ==> do - let p = octal - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "octal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs octal "" `shouldFailWith` - err posI (ueof <> elabel "octal integer") - - describe "float" $ do - context "when stream begins with a float" $ - it "parses it" $ - property $ \n' -> do - let p = float - n = getNonNegative n' - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with a float" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = float - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "floating point number") - prs' p s `failsLeaving` s - context "when stream begins with a decimal number" $ - it "signals correct parse error" $ - property $ \n' -> do - let p = float - n = getNonNegative n' - s = show (n :: Integer) - prs p s `shouldFailWith` err (posN (length s) s) - (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit") - prs' p s `failsLeaving` "" - context "when stream is empty" $ - it "signals correct parse error" $ - prs float "" `shouldFailWith` - err posI (ueof <> elabel "floating point number") - context "when there is float with exponent without explicit sign" $ - it "parses it all right" $ do - let p = float - s = "123e3" - prs p s `shouldParse` 123e3 - prs' p s `succeedsLeaving` "" - - describe "number" $ do - context "when stream begins with a number" $ - it "parses it" $ - property $ \n' -> do - let p = number - s = either (show . getNonNegative) (show . getNonNegative) - (n' :: Either (NonNegative Integer) (NonNegative Double)) - prs p s `shouldParse` case n' of - Left x -> fromIntegral (getNonNegative x) - Right x -> fromFloatDigits (getNonNegative x) - prs' p s `succeedsLeaving` "" - context "when stream is empty" $ - it "signals correct parse error" $ - prs number "" `shouldFailWith` - err posI (ueof <> elabel "number") - - describe "signed" $ do - context "with integer" $ - it "parses signed integers" $ - property $ \n -> do - let p = signed (hidden C.space) integer - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with float" $ - it "parses signed floats" $ - property $ \n -> do - let p = signed (hidden C.space) float - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with number" $ - it "parses singed numbers" $ - property $ \n -> do - let p = signed (hidden C.space) number - s = either show show (n :: Either Integer Double) - prs p s `shouldParse` case n of - Left x -> fromIntegral x - Right x -> fromFloatDigits x - context "when number is prefixed with plus sign" $ - it "parses the number" $ - property $ \n' -> do - let p = signed (hidden C.space) integer - n = getNonNegative n' - s = '+' : show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when number is prefixed with white space" $ - it "signals correct parse error" $ - property $ \n -> do - let p = signed (hidden C.space) integer - s = ' ' : show (n :: Integer) - prs p s `shouldFailWith` err posI - (utok ' ' <> etok '+' <> etok '-' <> elabel "integer") - prs' p s `failsLeaving` s - context "when there is white space between sign and digits" $ - it "parses it all right" $ do - let p = signed (hidden C.space) integer - s = "- 123" - prs p s `shouldParse` (-123) - prs' p s `succeedsLeaving` "" - ----------------------------------------------------------------------------- --- Helpers - -mkWhiteSpace :: Gen String -mkWhiteSpace = concat <$> listOf whiteUnit - where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock] - -mkWhiteSpaceNl :: Gen String -mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n" - -mkSymbol :: Gen String -mkSymbol = (++) <$> symbolName <*> whiteChars - -mkInterspace :: String -> Int -> Gen String -mkInterspace x n = oneof [si, mkIndent x n] - where si = (++ x) <$> listOf (elements " \t") - -mkIndent :: String -> Int -> Gen String -mkIndent x n = (++) <$> mkIndent' x n <*> eol - where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))] - -mkIndent' :: String -> Int -> Gen String -mkIndent' x n = concat <$> sequence [spc, sym, tra] - where spc = frequency [(5, vectorOf n itm), (1, listOf itm)] - tra = listOf itm - itm = elements " \t" - sym = return x - -whiteChars :: Gen String -whiteChars = listOf (elements "\t\n ") - -whiteLine :: Gen String -whiteLine = commentOut <$> arbitrary `suchThat` goodEnough - where commentOut x = "//" ++ x ++ "\n" - goodEnough x = '\n' `notElem` x - -whiteBlock :: Gen String -whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough - where commentOut x = "/*" ++ x ++ "*/" - goodEnough x = not $ "*/" `isInfixOf` x - -symbolName :: Gen String -symbolName = listOf $ arbitrary `suchThat` isAlphaNum - -sc :: Parser () -sc = space (void $ C.oneOf " \t") empty empty - -scn :: Parser () -scn = space (void C.spaceChar) l b - where l = skipLineComment "//" - b = skipBlockComment "/*" "*/" - -getIndent :: String -> Int -getIndent = length . takeWhile isSpace - -getCol :: String -> Pos -getCol x = sourceColumn . - updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x - -sbla, sblb, sblc :: String -sbla = "aaa" -sblb = "bbb" -sblc = "ccc" - -ii :: Ordering -> Pos -> Pos -> EC Char Dec -ii ord ref actual = cstm (DecIndentation ord ref actual) diff --git a/tests/Text/Megaparsec/PermSpec.hs b/tests/Text/Megaparsec/PermSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/PermSpec.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -module Text.Megaparsec.PermSpec (spec) where - -import Control.Applicative -import Data.List (nub, elemIndices) -import Data.Monoid -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Char -import Text.Megaparsec.Lexer (integer) -import Text.Megaparsec.Perm - -data CharRows = CharRows - { getChars :: (Char, Char, Char) - , getInput :: String } - deriving (Eq, Show) - -instance Arbitrary CharRows where - arbitrary = do - chars@(a,b,c) <- arbitrary `suchThat` different - an <- arbitrary - bn <- arbitrary - cn <- arbitrary - input <- concat <$> shuffle - [ replicate an a - , replicate bn b - , replicate cn c] - return $ CharRows chars input - where different (a,b,c) = let l = [a,b,c] in l == nub l - -spec :: Spec -spec = do - - describe "(<$$>)" $ do - context "when supplied parser succeeds" $ - it "returns value returned by the parser" $ - property $ \n -> do - let p = makePermParser (succ <$$> pure (n :: Integer)) - prs p "" `shouldParse` succ n - context "when supplied parser fails" $ - it "signals correct parse error" $ do - let p = makePermParser (succ <$$> integer) - prs p "" `shouldFailWith` err posI (ueof <> elabel "integer") - - describe "(<$?>)" $ do - context "when supplied parser succeeds" $ - it "returns value returned by the parser" $ - property $ \n m -> do - let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer))) - prs p "" `shouldParse` succ m - context "when supplied parser fails" $ - it "returns the default value" $ - property $ \n -> do - let p = makePermParser (succ <$?> (n :: Integer, fail "foo")) - prs p "" `shouldParse` succ n - context "when stream in empty" $ - it "returns the default value" $ - property $ \n -> do - let p = makePermParser (succ <$?> (n :: Integer, integer)) - prs p "" `shouldParse` succ n - - describe "makeExprParser" $ - it "works" $ - property $ \a' c' v -> do - let (a,b,c) = getChars v - p = makePermParser - ((,,) <$?> (a' :: String, some (char a)) - <||> char b - <|?> (c', char c)) - bis = elemIndices b s - preb = take (bis !! 1) s - cis = elemIndices c s - prec = take (cis !! 1) s - s = getInput v - if | length bis > 1 && (length cis <= 1 || head bis < head cis) -> - prs_ p s `shouldFailWith` err (posN (bis !! 1) s) - ( utok b <> eeof <> - (if a `elem` preb then mempty else etok a) <> - (if c `elem` preb then mempty else etok c) ) - | length cis > 1 -> - prs_ p s `shouldFailWith` err (posN (cis !! 1) s) - ( utok c <> - (if a `elem` prec then mempty else etok a) <> - (if b `elem` prec then eeof else etok b) ) - | b `notElem` s -> - prs_ p s `shouldFailWith` err (posN (length s) s) - ( ueof <> etok b <> - (if a `notElem` s || last s == a then etok a else mempty) <> - (if c `elem` s then mempty else etok c) ) - | otherwise -> - prs_ p s `shouldParse` - ( if a `elem` s then filter (== a) s else a' - , b - , if c `elem` s then c else c' ) diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/PosSpec.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.Megaparsec.PosSpec (spec) where - -import Data.Function (on) -import Data.List (isInfixOf) -import Data.Semigroup ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Pos - -#if !MIN_VERSION_base(4,8,0) -import Data.Word (Word) -#endif - -spec :: Spec -spec = do - - describe "mkPos" $ do - context "when the argument is 0" $ - it "throws InvalidPosException" $ - mkPos (0 :: Word) `shouldThrow` (== InvalidPosException) - context "when the argument is not 0" $ - it "returns Pos with the given value" $ - property $ \n -> - (n > 0) ==> (mkPos n >>= shouldBe n . unPos) - - describe "unsafePos" $ - context "when the argument is a positive integer" $ - it "returns Pos with the given value" $ - property $ \n -> - (n > 0) ==> (unPos (unsafePos n) === n) - - describe "Read and Show instances of Pos" $ - it "printed representation of Pos is isomorphic to its value" $ - property $ \x -> - read (show x) === (x :: Pos) - - describe "Ord instance of Pos" $ - it "works just like Ord instance of underlying Word" $ - property $ \x y -> - compare x y === (compare `on` unPos) x y - - describe "Semigroup instance of Pos" $ - it "works like addition" $ - property $ \x y -> - x <> y === unsafePos (unPos x + unPos y) .&&. - unPos (x <> y) === unPos x + unPos y - - describe "initialPos" $ - it "consturcts initial position correctly" $ - property $ \path -> - let x = initialPos path - in sourceName x === path .&&. - sourceLine x === unsafePos 1 .&&. - sourceColumn x === unsafePos 1 - - describe "Read and Show instances of SourcePos" $ - it "printed representation of SourcePos in isomorphic to its value" $ - property $ \x -> - read (show x) === (x :: SourcePos) - - describe "sourcePosPretty" $ do - it "displays file name" $ - property $ \x -> - sourceName x `isInfixOf` sourcePosPretty x - it "displays line number" $ - property $ \x -> - (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x - it "displays column number" $ - property $ \x -> - (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x - - describe "defaultUpdatePos" $ do - it "returns actual position unchanged" $ - property $ \w pos ch -> - fst (defaultUpdatePos w pos ch) === pos - it "does not change file name" $ - property $ \w pos ch -> - (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos - context "when given newline character" $ - it "increments line number" $ - property $ \w pos -> - (sourceLine . snd) (defaultUpdatePos w pos '\n') - === (sourceLine pos <> pos1) - context "when given tab character" $ - it "shits column number to next tab position" $ - property $ \w pos -> - let c = sourceColumn pos - c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t') - in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0) - context "when given character other than newline or tab" $ - it "increments column number by one" $ - property $ \w pos ch -> - (ch /= '\n' && ch /= '\t') ==> - (sourceColumn . snd) (defaultUpdatePos w pos ch) - === (sourceColumn pos <> pos1) diff --git a/tests/Text/Megaparsec/PrimSpec.hs b/tests/Text/Megaparsec/PrimSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/PrimSpec.hs +++ /dev/null @@ -1,1535 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.Megaparsec.PrimSpec (spec) where - -import Control.Applicative -import Control.Monad.Cont -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.Reader -import Data.Char (toUpper, chr) -import Data.Foldable (asum, concat) -import Data.Function (on) -import Data.List (isPrefixOf, foldl') -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, listToMaybe, isJust) -import Data.Monoid -import Data.Proxy -import Data.Word (Word8) -import Prelude hiding (span, concat) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck hiding (label) -import Text.Megaparsec.Char -import Text.Megaparsec.Combinator -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import Text.Megaparsec.Prim -import Text.Megaparsec.String -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.State.Lazy as L -import qualified Control.Monad.State.Strict as S -import qualified Control.Monad.Writer.Lazy as L -import qualified Control.Monad.Writer.Strict as S -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as G -import qualified Data.Set as E -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -#if !MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where - arbitrary = E.fromList <$> arbitrary - shrink = fmap E.fromList . shrink . E.toList -#endif - -spec :: Spec -spec = do - - describe "non-String instances of Stream" $ do - context "lazy ByteString" $ do - it "unconses correctly" $ - property $ \ch' n -> do - let p = many (char ch) :: Parsec Dec BL.ByteString String - s = replicate (getNonNegative n) ch - ch = byteToChar ch' - parse p "" (BL.pack s) `shouldParse` s - it "updates position like with String" $ - property $ \w pos ch -> - updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe` - updatePos (Proxy :: Proxy String) w pos ch - context "strict ByteString" $ do - it "unconses correctly" $ - property $ \ch' n -> do - let p = many (char ch) :: Parsec Dec B.ByteString String - s = replicate (getNonNegative n) ch - ch = byteToChar ch' - parse p "" (B.pack s) `shouldParse` s - it "updates position like with String" $ - property $ \w pos ch -> - updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe` - updatePos (Proxy :: Proxy String) w pos ch - context "lazy Text" $ do - it "unconses correctly" $ - property $ \ch n -> do - let p = many (char ch) :: Parsec Dec TL.Text String - s = replicate (getNonNegative n) ch - parse p "" (TL.pack s) `shouldParse` s - it "updates position like with String" $ - property $ \w pos ch -> - updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe` - updatePos (Proxy :: Proxy String) w pos ch - context "strict Text" $ do - it "unconses correctly" $ - property $ \ch n -> do - let p = many (char ch) :: Parsec Dec T.Text String - s = replicate (getNonNegative n) ch - parse p "" (T.pack s) `shouldParse` s - it "updates position like with String" $ - property $ \w pos ch -> - updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe` - updatePos (Proxy :: Proxy String) w pos ch - - describe "position in custom stream" $ do - - describe "eof" $ - it "updates position in stream correctly" $ - property $ \st -> (not . null . stateInput) st ==> do - let p = eof :: CustomParser () - h = head (stateInput st) - apos = let (_:|z) = statePos st in spanStart h :| z - runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utok h <> eeof) ) - - describe "token" $ do - context "when input stream is empty" $ - it "signals correct parse error" $ - property $ \st'@State {..} span -> do - let p = pSpan span - st = (st' :: State [Span]) { stateInput = [] } - runParser' p st `shouldBe` - ( st - , Left (err statePos $ ueof <> etok span) ) - context "when head of stream matches" $ - it "updates parser state correctly" $ - property $ \st'@State {..} span -> do - let p = pSpan span - st = st' { stateInput = span : stateInput } - npos = spanEnd span :| NE.tail statePos - runParser' p st `shouldBe` - ( st { statePos = npos - , stateTokensProcessed = stateTokensProcessed + 1 - , stateInput = stateInput } - , Right span ) - context "when head of stream does not match" $ do - let checkIt s span = - let ms = listToMaybe s - in isJust ms && (spanBody <$> ms) /= Just (spanBody span) - it "signals correct parse error" $ - property $ \st@State {..} span -> checkIt stateInput span ==> do - let p = pSpan span - h = head stateInput - apos = spanStart h :| NE.tail statePos - runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utok h <> etok span)) - - describe "tokens" $ - it "updates position is stream correctly" $ - property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do - let p = tokens compareTokens ts :: CustomParser [Span] - compareTokens x y = spanBody x == spanBody y - updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth - il = length . takeWhile id $ zipWith compareTokens stateInput ts - tl = length ts - consumed = take il stateInput - (apos, npos) = - let (pos:|z) = statePos - in ( spanStart (head stateInput) :| z - , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) - if | null ts -> runParser' p st `shouldBe` (st, Right []) - | null stateInput -> runParser' p st `shouldBe` - ( st - , Left (err statePos $ ueof <> etoks ts) ) - | il == tl -> runParser' p st `shouldBe` - ( st { statePos = npos - , stateTokensProcessed = stateTokensProcessed + fromIntegral tl - , stateInput = drop (length ts) stateInput } - , Right consumed ) - | otherwise -> runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) ) - - describe "getNextTokenPosition" $ do - context "when input stream is empty" $ - it "returns Nothing" $ - property $ \st' -> do - let p :: CustomParser (Maybe SourcePos) - p = getNextTokenPosition - st = (st' :: State [Span]) { stateInput = [] } - runParser' p st `shouldBe` (st, Right Nothing) - context "when input stream is not empty" $ - it "return the position of start of the next token" $ - property $ \st' h -> do - let p :: CustomParser (Maybe SourcePos) - p = getNextTokenPosition - st = st' { stateInput = h : stateInput st' } - runParser' p st `shouldBe` (st, (Right . Just . spanStart) h) - - describe "ParsecT Semigroup instance" $ - it "the associative operation works" $ - property $ \a b -> do - let p = pure [a] G.<> pure [b] - prs p "" `shouldParse` ([a,b] :: [Int]) - - describe "ParsecT Monoid instance" $ do - it "mempty works" $ do - let p = mempty - prs p "" `shouldParse` ([] :: [Int]) - it "mappend works" $ - property $ \a b -> do - let p = pure [a] `mappend` pure [b] - prs p "" `shouldParse` ([a,b] :: [Int]) - - describe "ParsecT Functor instance" $ do - it "obeys identity law" $ - property $ \n -> - prs (fmap id (pure (n :: Int))) "" === - prs (id (pure n)) "" - it "obeys composition law" $ - property $ \n m t -> - let f = (+ m) - g = (* t) - in prs (fmap (f . g) (pure (n :: Int))) "" === - prs ((fmap f . fmap g) (pure n)) "" - - describe "ParsecT Applicative instance" $ do - it "obeys identity law" $ - property $ \n -> - prs (pure id <*> pure (n :: Int)) "" === - prs (pure n) "" - it "obeys composition law" $ - property $ \n m t -> - let u = pure (+ m) - v = pure (* t) - w = pure (n :: Int) - in prs (pure (.) <*> u <*> v <*> w) "" === - prs (u <*> (v <*> w)) "" - it "obeys homomorphism law" $ - property $ \x m -> - let f = (+ m) - in prs (pure f <*> pure (x :: Int)) "" === - prs (pure (f x)) "" - it "obeys interchange law" $ - property $ \n y -> - let u = pure (+ n) - in prs (u <*> pure (y :: Int)) "" === - prs (pure ($ y) <*> u) "" - describe "(<*>)" $ - context "when first parser succeeds without consuming" $ - context "when second parser fails consuming input" $ - it "fails consuming input" $ do - let p = m <*> n - m = return (\x -> 'a' : x) - n = string "bc" <* empty - s = "bc" - prs p s `shouldFailWith` err (posN (4 :: Int) s) mempty - prs' p s `failsLeaving` "" - describe "(*>)" $ - it "works correctly" $ - property $ \n m -> - let u = pure (+ (m :: Int)) - v = pure (n :: Int) - in prs (u *> v) "" === - prs (pure (const id) <*> u <*> v) "" - describe "(<*)" $ - it "works correctly" $ - property $ \n m -> - let u = pure (m :: Int) - v = pure (+ (n :: Int)) - in prs (u <* v) "" === prs (pure const <*> u <*> v) "" - - describe "ParsecT Alternative instance" $ do - - describe "empty" $ - it "always fails" $ - property $ \n -> - prs (empty <|> pure n) "" `shouldParse` (n :: Integer) - - describe "(<|>)" $ do - context "with two strings" $ do - context "stream begins with the first string" $ - it "parses the string" $ - property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do - let s' = s0 ++ s - p = string s0 <|> string s1 - prs p s' `shouldParse` s0 - prs' p s' `succeedsLeaving` s - context "stream begins with the second string" $ - it "parses the string" $ - property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do - let s' = s1 ++ s - p = string s0 <|> string s1 - prs p s' `shouldParse` s1 - prs' p s' `succeedsLeaving` s - context "when stream does not begin with either string" $ - it "signals correct error message" $ - property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do - let p = string s0 <|> string s1 - z0' = toFirstMismatch (==) s0 s - z1' = toFirstMismatch (==) s1 s - prs p s `shouldFailWith` err posI - (etoks s0 <> - etoks s1 <> - (if null s then ueof else mempty) <> - (if null z0' then mempty else utoks z0') <> - (if null z1' then mempty else utoks z1')) - context "with two complex parsers" $ do - context "when stream begins with matching character" $ - it "parses it" $ - property $ \a b -> a /= b ==> do - let p = char a <|> (char b *> char a) - s = [a] - prs p s `shouldParse` a - prs' p s `succeedsLeaving` "" - context "when stream begins with only one matching character" $ - it "signals correct parse error" $ - property $ \a b c -> a /= b && a /= c ==> do - let p = char a <|> (char b *> char a) - s = [b,c] - prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a) - prs' p s `failsLeaving` [c] - context "when stream begins with not matching character" $ - it "signals correct parse error" $ - property $ \a b c -> a /= b && a /= c && b /= c ==> do - let p = char a <|> (char b *> char a) - s = [c,b] - prs p s `shouldFailWith` err posI (utok c <> etok a <> etok b) - prs' p s `failsLeaving` s - context "when stream is emtpy" $ - it "signals correct parse error" $ - property $ \a b -> do - let p = char a <|> (char b *> char a) - prs p "" `shouldFailWith` err posI (ueof <> etok a <> etok b) - it "associativity of fold over alternatives should not matter" $ do - let p = asum [empty, string ">>>", empty, return "foo"] "bar" - p' = bsum [empty, string ">>>", empty, return "foo"] "bar" - bsum = foldl (<|>) empty - s = ">>" - prs p s `shouldBe` prs p' s - - describe "many" $ do - context "when stream begins with things argument of many parses" $ - it "they are parsed" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = many (char 'a') - s = abcRow a b c - prs p s `shouldParse` replicate a 'a' - prs' p s `succeedsLeaving` drop a s - context "when stream does not begin with thing argument of many parses" $ - it "does nothing" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = many (char 'd') - s = abcRow a b c - prs p s `shouldParse` "" - prs' p s `succeedsLeaving` s - context "when stream is empty" $ - it "succeeds parsing nothing" $ do - let p = many (char 'a') - prs p "" `shouldParse` "" - context "when there are two many combinators in a row that parse nothing" $ - it "accumulated hints are reflected in parse error" $ do - let p = many (char 'a') *> many (char 'b') *> eof - prs p "c" `shouldFailWith` err posI - (utok 'c' <> etok 'a' <> etok 'b' <> eeof) - context "when the argument parser succeeds without consuming" $ - it "is run nevertheless" $ - property $ \n' -> do - let n = getSmall (getNonNegative n') :: Integer - p = void . many $ do - x <- S.get - if x < n then S.modify (+ 1) else empty - v :: S.State Integer (Either (ParseError Char Dec) ()) - v = runParserT p "" "" - S.execState v 0 `shouldBe` n - - describe "some" $ do - context "when stream begins with things argument of some parses" $ - it "they are parsed" $ - property $ \a' b' c' -> do - let a = getPositive a' - [b,c] = getNonNegative <$> [b',c'] - p = some (char 'a') - s = abcRow a b c - prs p s `shouldParse` replicate a 'a' - prs' p s `succeedsLeaving` drop a s - context "when stream does not begin with thing argument of some parses" $ - it "signals correct parse error" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = some (char 'd') - s = abcRow a b c ++ "g" - prs p s `shouldFailWith` err posI (utok (head s) <> etok 'd') - prs' p s `failsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> do - let p = some (char ch) - prs p "" `shouldFailWith` err posI (ueof <> etok ch) - context "optional" $ do - context "when stream begins with that optional thing" $ - it "parses it" $ - property $ \a b -> do - let p = optional (char a) <* char b - s = [a,b] - prs p s `shouldParse` Just a - prs' p s `succeedsLeaving` "" - context "when stream does not begin with that optional thing" $ - it "succeeds parsing nothing" $ - property $ \a b -> a /= b ==> do - let p = optional (char a) <* char b - s = [b] - prs p s `shouldParse` Nothing - prs' p s `succeedsLeaving` "" - context "when stream is empty" $ - it "succeeds parsing nothing" $ - property $ \a -> do - let p = optional (char a) - prs p "" `shouldParse` Nothing - - describe "ParsecT Monad instance" $ do - it "satisfies left identity law" $ - property $ \a k' -> do - let k = return . (+ k') - p = return (a :: Int) >>= k - prs p "" `shouldBe` prs (k a) "" - it "satisfies right identity law" $ - property $ \a -> do - let m = return (a :: Int) - p = m >>= return - prs p "" `shouldBe` prs m "" - it "satisfies associativity law" $ - property $ \m' k' h' -> do - let m = return (m' :: Int) - k = return . (+ k') - h = return . (* h') - p = m >>= (\x -> k x >>= h) - p' = (m >>= k) >>= h - prs p "" `shouldBe` prs p' "" - it "fails signals correct parse error" $ - property $ \msg -> do - let p = fail msg :: Parsec Dec String () - prs p "" `shouldFailWith` err posI (cstm (DecFail msg)) - it "pure is the same as return" $ - property $ \n -> - prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" - it "(<*>) is the same as ap" $ - property $ \m' k' -> do - let m = return (m' :: Int) - k = return (+ k') - prs (k <*> m) "" `shouldBe` prs (k `ap` m) "" - - describe "ParsecT MonadFail instance" $ - describe "fail" $ - it "signals correct parse error" $ - property $ \s msg -> do - let p = void (fail msg) - prs p s `shouldFailWith` err posI (cstm $ DecFail msg) - prs' p s `failsLeaving` s - - describe "ParsecT MonadIO instance" $ - it "liftIO works" $ - property $ \n -> do - let p = liftIO (return n) :: ParsecT Dec String IO Integer - runParserT p "" "" `shouldReturn` Right n - - describe "ParsecT MonadReader instance" $ do - - describe "ask" $ - it "returns correct value of context" $ - property $ \n -> do - let p = ask :: ParsecT Dec String (Reader Integer) Integer - runReader (runParserT p "" "") n `shouldBe` Right n - - describe "local" $ - it "modifies reader context correctly" $ - property $ \n k -> do - let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer - runReader (runParserT p "" "") n `shouldBe` Right (n + k) - - describe "ParsecT MonadState instance" $ do - - describe "get" $ - it "returns correct state value" $ - property $ \n -> do - let p = L.get :: ParsecT Dec String (L.State Integer) Integer - L.evalState (runParserT p "" "") n `shouldBe` Right n - describe "put" $ - it "replaces state value" $ - property $ \a b -> do - let p = L.put b :: ParsecT Dec String (L.State Integer) () - L.execState (runParserT p "" "") a `shouldBe` b - - describe "ParsecT MonadCont instance" $ - - describe "callCC" $ - it "works properly" $ - property $ \a b -> do - let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer - p = callCC $ \e -> when (a > b) (e a) >> return b - runCont (runParserT p "" "") id `shouldBe` Right (max a b) - - describe "ParsecT MonadError instance" $ do - - describe "throwError" $ - it "throws the error" $ - property $ \a b -> do - let p :: ParsecT Dec String (Except Integer) Integer - p = throwError a >> return b - runExcept (runParserT p "" "") `shouldBe` Left a - - describe "catchError" $ - it "catches the error" $ - property $ \a b -> do - let p :: ParsecT Dec String (Except Integer) Integer - p = (throwError a >> return b) `catchError` handler - handler e = return (e + b) - runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b) - - describe "primitive combinators" $ do - - describe "unexpected" $ - it "signals correct parse error" $ - property $ \item -> do - let p :: MonadParsec Dec String m => m () - p = void (unexpected item) - grs p "" (`shouldFailWith` ParseError - { errorPos = posI - , errorUnexpected = E.singleton item - , errorExpected = E.empty - , errorCustom = E.empty }) - - describe "match" $ - it "return consumed tokens along with the result" $ - property $ \str -> do - let p = match (string str) - prs p str `shouldParse` (str,str) - prs' p str `succeedsLeaving` "" - - describe "region" $ do - context "when inner parser succeeds" $ - it "has no effect" $ - property $ \st e n -> do - let p :: Parser Int - p = region (const e) (pure n) - runParser' p st `shouldBe` (st, Right (n :: Int)) - context "when inner parser fails" $ - it "the given function is used on the parse error" $ - property $ \st e0 e1 -> do - let p :: Parser Int - p = region f $ failure - (errorUnexpected e0) - (errorExpected e0) - (errorCustom e0) - f x = ParseError - { errorPos = ((G.<>) `on` errorPos) x e1 - , errorUnexpected = (E.union `on` errorUnexpected) x e1 - , errorExpected = (E.union `on` errorExpected) x e1 - , errorCustom = (E.union `on` errorCustom) x e1 } - r = ParseError - { errorPos = finalPos - , errorUnexpected = (E.union `on` errorUnexpected) e0 e1 - , errorExpected = (E.union `on` errorExpected) e0 e1 - , errorCustom = (E.union `on` errorCustom) e0 e1 } - finalPos = statePos st G.<> errorPos e1 - runParser' p st `shouldBe` (st { statePos = finalPos }, Left r) - - describe "failure" $ - it "signals correct parse error" $ - property $ \us ps xs -> do - let p :: MonadParsec Dec String m => m () - p = void (failure us ps xs) - grs p "" (`shouldFailWith` ParseError - { errorPos = posI - , errorUnexpected = us - , errorExpected = ps - , errorCustom = xs }) - - describe "label" $ do - context "when inner parser succeeds consuming input" $ do - context "inner parser does not produce any hints" $ - it "collection of hints remains empty" $ - property $ \lbl a -> not (null lbl) ==> do - let p :: MonadParsec Dec String m => m Char - p = label lbl (char a) <* empty - s = [a] - grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty) - grs' p s (`failsLeaving` "") - context "inner parser produces hints" $ - it "replaces the last hint with “the rest of