diff --git a/AUTHORS.md b/AUTHORS.md deleted file mode 100644 --- a/AUTHORS.md +++ /dev/null @@ -1,54 +0,0 @@ -# Authors - -The following people have contributed to Megaparsec/Parsec library. Due to -the fact that original Parsec project has not been keeping this sort of -file, many contributors are missing from this list, if you've contributed to -Parsec project in the past, please open an issue or a pull request, so we -can add you to this list. - -Names below are sorted alphabetically. - -## Author of original Parsec library - -* Daan Leijen - -## Maintainer - -* Mark Karpov - -## Retired maintainers - -* Antoine Latter -* Derek Elkins - -## Contributors - -* Albert Netymk -* Alex Washburn (@recursion-ninja) -* Antoine Latter -* Artyom (@neongreen) -* Auke Booij -* Ben Pence -* Benjamin Kästner -* Björn Buckwalter -* Bryan O'Sullivan -* Cies Breijs -* Daniel Díaz -* Daniel Gorín -* Dennis Gosnell -* Derek Elkins -* Emil Sköldberg -* Herbert Valerio Riedel -* Joel Williamson -* Mark Karpov -* Paolo Martini -* redneb -* Reto Kramer -* Rogan Creswick -* Roman Cheplyaka -* Ryan Scott -* Simon Vandel -* Slava Shklyaev -* Tal Walter -* Tomáš Janoušek -* Vladislav Zavialov diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,359 @@ +*Megaparsec follows [SemVer](https://semver.org/).* + +## Megaparsec 9.8.1 + +* Fixed the regression introduced by the fix for the [issue + 572](https://github.com/mrkkrp/megaparsec/issues/572) which caused the + position marker `^` to be missing in certain cases. +* This release officially supports GHC 9.6. This is the oldest GHC version + we support at this time. + +## Megaparsec 9.8.0 + +* Fixed the associativity of the `(<|>)` operator. [Issue + 412](https://github.com/mrkkrp/megaparsec/issues/412). +* Fixed the loss of precision in `decimal`, `binary`, `octal`, and + `hexadecimal` functions in `Text.Megaparsec.Byte.Lexer` and + `Text.Megaparsec.Char.Lexer` when they are used to parse floating point + numbers. [Issue 479](https://github.com/mrkkrp/megaparsec/issues/479). +* Fixed handling of zero-width characters in error messages. To that end, + added `isZeroWidthChar` function in `Text.Megaparsec.Unicode`. [Issue + 572](https://github.com/mrkkrp/megaparsec/issues/572). + +## Megaparsec 9.7.1 + +* Typo fixes and compatibility with `QuickCheck >= 2.17` for + `megaparsec-tests`. + +## Megaparsec 9.7.0 + +* Implemented correct handling of wide Unicode characters in error messages. + To that end, a new module `Text.Megaparsec.Unicode` was introduced. [Issue + 370](https://github.com/mrkkrp/megaparsec/issues/370). +* Inlined `Applicative` operators `(<*)` and `(*>)`. [PR + 566](https://github.com/mrkkrp/megaparsec/pull/566). +* `many` and `some` of the `Alternative` instance of `ParsecT` are now more + efficient, since they use the monadic implementations under the hood. + [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567). +* Added `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR + 573](https://github.com/mrkkrp/megaparsec/pull/573). + +## Megaparsec 9.6.1 + +* Exposed `Text.Megaparsec.State`, so that the new functions (`initialState` + and `initialPosState`) can be actually imported from it. [PR + 549](https://github.com/mrkkrp/megaparsec/pull/549). + +## Megaparsec 9.6.0 + +* Added the functions `initialState` and `initialPosState` to + `Text.Megaparsec.State`. [Issue + 449](https://github.com/mrkkrp/megaparsec/issues/449). + +## Megaparsec 9.5.0 + +* Dropped a number of redundant constraints here and there. [PR + 523](https://github.com/mrkkrp/megaparsec/pull/523). + +* Added a `MonadWriter` instance for `ParsecT`. [PR + 534](https://github.com/mrkkrp/megaparsec/pull/534). + +## Megaparsec 9.4.1 + +* Removed `Monad m` constraints in several places where they were introduced + in 9.4.0. [Issue 532](https://github.com/mrkkrp/megaparsec/issues/532). + +## Megaparsec 9.4.0 + +* `dbg` now prints hints among other debug information. [PR + 530](https://github.com/mrkkrp/megaparsec/pull/530). + +* Hints are no longer lost in certain methods of MTL instances for + `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528). + +* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be + used to construct “new primitives” with arbitrary behavior at the expense + of having to dive into Megaparsec's internals. [PR + 514](https://github.com/mrkkrp/megaparsec/pull/514). + +## Megaparsec 9.3.1 + +* Fixed a bug related to processing of tabs when error messages are + rendered. [Issue 524](https://github.com/mrkkrp/megaparsec/issues/524). + +## Megaparsec 9.3.0 + +* Now `label` can override more than one group of hints in the parser it + wraps. [Issue 482](https://github.com/mrkkrp/megaparsec/issues/482). + +* `takeP n` now returns the empty chunk of the input stream when `n` is + negative, similar to when `n == 0`. [Issue + 497](https://github.com/mrkkrp/megaparsec/issues/497). + +* Added the `MonadParsecDbg` type class in `Text.Megaparsec.Debug`. The type + class allows us to use `dbg` in MTL monad transformers. [Issue + 488](https://github.com/mrkkrp/megaparsec/issues/488). + +* Introduced the `ShareInput` and `NoShareInput` newtype wrappers in + `Text.Megaparsec.Stream` in order to allow the user to choose how the + input should be sliced and shared during the parsing. [Issue + 492](https://github.com/mrkkrp/megaparsec/issues/492). + +## Megaparsec 9.2.2 + +* Fixed a space leak in the implementations of the `reachOffset` and + `reachOffsetNoLine` methods of `TraversableStream`. [Issue + 486](https://github.com/mrkkrp/megaparsec/issues/486). + +## Megaparsec 9.2.1 + +* Builds with `mtl-2.3` and `transformers-0.6`. + +## Megaparsec 9.2.0 + +* Added parsers for binary representations (little/big endian) of numbers in + `Text.Megaparsec.Byte.Binary`. + +## Megaparsec 9.1.0 + +* Added `dbg'` in `Text.Megaparsec.Debug` for debugging parsers that have + unshowable return values. + +* Documentation improvements. + +## Megaparsec 9.0.1 + +* Added [Safe + Haskell](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html) + support. + +## Megaparsec 9.0.0 + +* Split the `Stream` type class. The methods `showTokens` and `tokensLength` + have been put into a separate type class `VisualStream`, while + `reachOffset` and `reachOffsetNoLine` are now in `TraversableStream`. This + should make defining `Stream` instances for custom streams easier. + +* Defined `Stream` instances for lists and `Seq`s. + +* Added the functions `hspace` and `hspace1` to the `Text.Megaparsec.Char` + and `Text.Megaparsec.Byte` modules. + +## Megaparsec 8.0.0 + +* The methods `failure` and `fancyFailure` of `MonadParsec` are now ordinary + functions and live in `Text.Megaparsec`. They are defined in terms of the + new `parseError` method of `MonadParsec`. This method allows us to signal + parse errors at a given offset without manipulating parser state manually. + +* Megaparsec now supports registration of “delayed” parse errors. On lower + level we added a new field called `stateParseErrors` to the `State` + record. The type also had to change from `State s` to `State s e`. This + field contains the list of registered `ParseErrors` that do not end + parsing immediately but still will cause failure in the end if the list is + not empty. Users are expected to register parse errors using the three + functions: `registerParseError`, `registerFailure`, and + `registerFancyFailure`. These functions are analogous to those without the + `register` prefix, except that they have “delayed” effect. + +* Added the `tokensLength` method to the `Stream` type class to improve + support for custom input streams. + +* Added the `setErrorOffset` function to set offset of `ParseError`s. + +* Changed type signatures of `reachOffset` and `reachOffsetNoLine` methods + of the `Stream` type class. Instead of three-tuple `reachOffset` now + returns two-tuple because `SourcePos` is already contained in the returned + `PosState` record. + +* Generalized `decimal`, `binary`, `octal`, and `hexadecimal` parsers in + lexer modules so that they `Num` instead of just `Integral`. + +* Dropped support for GHC 8.2.x and older. + +## Megaparsec 7.0.5 + +* Dropped support for GHC 7.10. + +* Adapted the code to `MonadFail` changes in `base-4.13`. + +* Separated the test suite into its own package. The reason is that we can + avoid circular dependency on `hspec-megaparsec` and thus avoid keeping + copies of its source files in our test suite, as we had to do before. + Another benefit is that we can export some auxiliary functions in + `megaparsec-tests` which can be used by other test suites, for example in + the `parser-combinators-tests` package. + + Version of `megaparsec-tests` will be kept in sync with versions of + `megaparsec` from now on. + +## Megaparsec 7.0.4 + +* Numerous documentation corrections. + +## Megaparsec 7.0.3 + +* Fixed the build with `mtl` older than `2.2.2`. + +## Megaparsec 7.0.2 + +* Fixed the property test for `char'` which was failing in the case when + there is a character with different upper and title cases. + +* More descriptive error messages when `elabel` or `ulabel` from + `Text.Megaparsec.Error.Builder` are used with empty strings. + +* Typo fixes in the docs. + +## Megaparsec 7.0.1 + +* Fixed a bug in `errorBundlePretty`. Previously the question sign `?` was + erroneously inserted before offending line in 2nd and later parse errors. + +## Megaparsec 7.0.0 + +### General + +* Dropped the `Text.Megaparsec.Perm` module. Use + `Control.Applicative.Permutations` from `parser-combinators` instead. + +* Dropped the `Text.Megaparsec.Expr` module. Use + `Control.Monad.Combinators.Expr` from `parser-combinators` instead. + +* The debugging function `dbg` has been moved from `Text.Megaparsec` to its + own module `Text.Megaparsec.Debug`. + +* Dropped support for GHC 7.8. + +### Combinators + +* Moved some general combinators from `Text.Megaparsec.Char` and + `Text.Megaparsec.Byte` to `Text.Megaparsec`, renaming some of them for + clarity. + + Practical consequences: + + * Now there is the `single` combinator that is a generalization of `char` + for arbitrary streams. `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` + still contain `char` as type-constrained versions of `single`. + + * Similarly, now there is the `chunk` combinator that is a generalization + of `string` for arbitrary streams. The `string` combinator is still + re-exported from `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` for + compatibility. + + * `satisfy` does not depend on type of token, and so it now lives in + `Text.Megaparsec`. + + * `anyChar` was renamed to `anySingle` and moved to `Text.Megaparsec`. + + * `notChar` was renamed to `anySingleBut` and moved to `Text.Megaparsec`. + + * `oneOf` and `noneOf` were moved to `Text.Megaparsec`. + +* Simplified the type of the `token` primitive. It now takes just a matching + function `Token s -> Maybe a` as the first argument and the collection of + expected items `Set (ErrorItem (Token s))` as the second argument. This + makes sense because the collection of expected items cannot depend on what + we see in the input stream. + +* The `label` primitive now doesn't prepend the phrase “the rest of” to the + label when its inner parser produces hints after consuming input. In that + case `label` has no effect. + +* Fixed the `Text.Megaparsec.Char.Lexer.charLiteral` so it can accept longer + escape sequences (max length is now 10). + +* Added the `binDigitChar` functions in `Text.Megaparsec.Byte` and + `Text.Megaparsec.Char`. + +* Added the `binary` functions in `Text.Megaparsec.Byte.Lexer` and + `Text.Megaparsec.Char.Lexer`. + +* Improved case-insensitive character matching in the cases when e.g. + `isLower` and `isUpper` both return `False`. Functions affected: + `Text.Megaparsec.Char.char'`. + +* Renamed `getPosition` to `getSourcePos`. + +* Renamed `getTokensProcessed` to `getOffset`, `setTokensProcessed` to + `setOffset`. + +* Dropped `getTabWidth` and `setTabWidth` because tab width is irrelevant to + parsing process now, it's only relevant for pretty-printing of parse + errors, which is handled separately. + +* Added and `withParsecT` in `Text.Megaparsec.Internal` to allow changing + the type of the custom data component in parse errors. + +### Parser state and input stream + +* Dropped stacks of source positions. Accordingly, the functions + `pushPosition` and `popPosition` from `Text.Megaparsec` and + `sourcePosStackPretty` from `Text.Megaparsec.Error` were removed. The + reason for this simplification is that I could not find any code that uses + the feature and it makes manipulation of source positions hairy. + +* Introduced `PosState` for calculating `SourcePos` from offsets and getting + offending line for displaying on pretty-printing of parse errors. It's now + contained in both `State` and `ParseErrorBundle`. + +* Dropped `positionAt1`, `positionAtN`, `advance1`, and `advanceN` methods + from `Stream`. They are no longer necessary because `reachOffset` (and its + specialized version `reachOffsetNoLine`) takes care of `SourcePos` + calculation. + +### Parse errors + +* `ParseError` now contains raw offset in input stream instead of + `SourcePos`. `errorPos` was dropped from `Text.Megaparsec.Error`. + +* `ParseError` is now parametrized over stream type `s` instead of token + type `t`. + +* Introduced `ParseErrorBundle` which contains one or more `ParseError` + equipped with all information that is necessary to pretty-print them + together with offending lines from the input stream. Functions like + `runParser` now return `ParseErrorBundle` instead of plain `ParseError`. + + By default there will be only one `ParseError` in such a bundle, but it's + possible to add more parse errors to a bundle manually. During + pretty-printing, the input stream will be traversed only once. + +* The primary function for pretty-printing of parse + errors—`errorBundlePretty` always prints offending lines now. + `parseErrorPretty` is still there, but it probably won't see a lot of use + from now on. `parseErrorPretty'` and `parseErrorPretty_` were removed. + `parseTest'` was removed because `parseTest` always prints offending lines + now. + +* Added `attachSourcePos` function in `Text.Megaparsec.Error`. + +* The `ShowToken` type class has been removed and its method `showTokens` + now lives in the `Stream` type class. + +* The `LineToken` type class is no longer necessary because the new method + `reachOffset` of the type class `Stream` does its job. + +* In `Text.Megaparsec.Error` the following functions were added: + `mapParseError`, `errorOffset`. + +* Implemented continuous highlighting in parse errors. For this we added the + `errorComponentLen` method to the `ShowErrorComponent` type class. + +### Parse error builder + +* The functions `err` and `errFancy` now accept offsets at which the parse + errors are expected to have happened, i.e. `Int`s. Thus `posI` and `posN` + are no longer necessary and were removed. + +* `ET` is now parametrized over the type of stream `s` instead of token type + `t`. + +* Combinators like `utoks` and `etoks` now accept chunks of input stream + directly, i.e. `Tokens s` instead of `[Token s]` which should be more + natural and convenient. + ## Megaparsec 6.5.0 * Added `Text.Megaparsec.Internal`, which exposes some internal data @@ -93,7 +449,7 @@ `Text.Megaparsec.Byte` if you intend to parse binary data, then add qualified modules you need (permutation parsing, lexing, expression parsing, etc.). `Text.Megaparsec.Lexer` was renamed to - `Text.Megaparec.Char.Lexer` because many functions in it has the `Token s + `Text.Megaparsec.Char.Lexer` because many functions in it has the `Token s ~ Char` constraint. There is also `Text.Megaparsec.Byte.Lexer` now, although it has fewer functions. @@ -186,17 +542,17 @@ * Added `notChar` in `Text.Megaparsec.Char`. -* Added `space1` in `Text.Megaprasec.Char`. This parser is like `space` but +* Added `space1` in `Text.Megaparsec.Char`. This parser is like `space` but requires at least one space character to be present to succeed. * Added new module `Text.Megaparsec.Byte`, which is similar to `Text.Megaparsec.Char`, but for token streams of the type `Word8` instead of `Char`. -* `integer` was dropped from `Text.Megaparec.Char.Lexer`. Use `decimal` +* `integer` was dropped from `Text.Megaparsec.Char.Lexer`. Use `decimal` instead. -* `number` was dropped from `Text.Megaparec.Char.Lexer`. Use `scientific` +* `number` was dropped from `Text.Megaparsec.Char.Lexer`. Use `scientific` instead. * `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return @@ -608,7 +964,7 @@ ### Built-in combinators * All built-in combinators in `Text.Megaparsec.Combinator` now work with any - instance of `Alternative` (some of them even with `Applicaitve`). + instance of `Alternative` (some of them even with `Applicative`). * Added more powerful `count'` parser. This parser can be told to parse from `m` to `n` occurrences of some thing. `count` is defined in terms of diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,5 +1,5 @@ -Copyright © 2015–2018 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,15 +4,13 @@ [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec) -[![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) +[![CI](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml) * [Features](#features) * [Core features](#core-features) * [Error messages](#error-messages) - * [Alex support](#alex-support) + * [External lexers](#external-lexers) * [Character and binary parsing](#character-and-binary-parsing) - * [Permutation parsing](#permutation-parsing) - * [Expression parsing](#expression-parsing) * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials) @@ -25,12 +23,11 @@ * [Related packages](#related-packages) * [Prominent projects that use Megaparsec](#prominent-projects-that-use-megaparsec) * [Links to announcements and blog posts](#links-to-announcements-and-blog-posts) -* [Authors](#authors) * [Contribution](#contribution) * [License](#license) This is an industrial-strength monadic parser combinator library. Megaparsec -is a feature-rich package that strikes a nice balance between speed, +is a feature-rich package that tries to find a nice balance between speed, flexibility, and quality of parse errors. ## Features @@ -42,157 +39,135 @@ ### Core features The package is built around `MonadParsec`, an MTL-style monad transformer. -All tools and features work with all instances of `MonadParsec`. You can -achieve various effects combining monad transformers, i.e. building a -monadic stack. Since the common monad transformers like `WriterT`, `StateT`, -`ReaderT` and others are instances of the `MonadParsec` type class, you can -wrap `ParsecT` *in* these monads, achieving, for example, backtracking -state. +Most features work with all instances of `MonadParsec`. One can achieve +various effects combining monad transformers, i.e. building a monadic stack. +Since the common monad transformers like `WriterT`, `StateT`, `ReaderT` and +others are instances of the `MonadParsec` type class, one can also wrap +`ParsecT` *in* these monads, achieving, for example, backtracking state. On the other hand `ParsecT` is an instance of many type classes as well. The most useful ones are `Monad`, `Applicative`, `Alternative`, and `MonadParsec`. -Megaparsec includes all functionality that is available in Parsec plus -features some combinators that are missing in other parsing libraries: +Megaparsec includes all functionality that is typically available in +Parsec-like libraries and also features some special combinators: -* `failure` allows to fail reporting a parse error with unexpected and - expected items. -* `fancyFailure` allows to fail reporting custom error messages. -* `withRecovery` allows to recover from parse errors “on-the-fly” and +* `parseError` allows us to end parsing and report an arbitrary parse error. +* `withRecovery` can be used to recover from parse errors “on-the-fly” and continue parsing. Once parsing is finished, several parse errors may be reported or ignored altogether. -* `observing` allows to “observe” parse errors without ending parsing (they - are returned in `Left`, while normal results are wrapped in `Right`). +* `observing` makes it possible to “observe” parse errors without ending + parsing. -In addition to that, Megaparsec 6 features high-performance combinators -similar to those found in Attoparsec: +In addition to that, Megaparsec features high-performance combinators +similar to those found in [Attoparsec][attoparsec]: * `tokens` makes it easy to parse several tokens in a row (`string` and `string'` are built on top of this primitive). This is about 100 times faster than matching a string token by token. `tokens` returns “chunk” of original input, meaning that if you parse `Text`, it'll return `Text` - without any repacking. + without repacking. * `takeWhile` and `takeWhile1` are about 150 times faster than approaches involving `many`, `manyTill` and other similar combinators. -* `takeP` allows to grab n tokens from the stream and returns them as a +* `takeP` allows us to grab n tokens from the stream and returns them as a “chunk” of the stream. -So now that we have matched the main “performance boosters” of Attoparsec, -Megaparsec 6 is not significantly slower than Attoparsec if you write your -parser carefully (see also [the section about performance](#performance)). +Megaparsec is about as fast as Attoparsec if you write your parser carefully +(see also [the section about performance](#performance)). -Megaparsec can currently work with the following types of input stream +The library can currently work with the following types of input stream out-of-the-box: -* `String` = `[Char]` +* `String = [Char]` * `ByteString` (strict and lazy) * `Text` (strict and lazy) -It's also simple to make it work with custom token streams, and Megaparsec -users have done so many times. +It's also possible to make it work with custom token streams by making them +an instance of the `Stream` type class. ### Error messages -Megaparsec 5 introduced well-typed error messages and the ability to use -custom data types to adjust the library to specific domain of interest. No -need to use a shapeless bunch of strings. +* Megaparsec has typed error messages and the ability to signal custom parse + errors that better suit the user's domain of interest. -The design of parse errors has been revised in version 6 significantly, but -custom errors are still easy (probably even easier now). +* Since version 8, the location of parse errors can independent of current + offset in the input stream. It is useful when you want a parse error to + point to a particular position after performing some checks. -### Alex support +* Instead of a single parse error Megaparsec produces so-called + `ParseErrorBundle` data type that helps to manage multi-error messages and + pretty-print them. Since version 8, reporting multiple parse errors at + once has become easier. +### External lexers + Megaparsec works well with streams of tokens produced by tools like Alex. -The design of the `Stream` type class has been changed significantly in -version 6, but user can still work with custom streams of tokens without -problems. +The design of the `Stream` type class has been changed significantly in the +recent versions, but user can still work with custom streams of tokens. ### Character and binary parsing Megaparsec has decent support for Unicode-aware character parsing. Functions -for character parsing live in the -[`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) -module. Similarly, there is -[`Text.Megaparsec.Byte`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte.html) -module for parsing streams of bytes. - -### Permutation parsing - -For those who are interested in parsing of permutation phrases, there is -[`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html). -You have to import the module explicitly, it's not included in the -`Text.Megaparsec` module. - -### Expression parsing - -Megaparsec has a solution for parsing of expressions. Take a look at -[`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html). -You have to import the module explicitly, it's not included in the -`Text.Megaparsec`. - -Given a table of operators that describes their fixity and precedence, you -can construct a parser that will parse any expression involving the -operators. See documentation for comprehensive description of how it works. +for character parsing live in the [`Text.Megaparsec.Char`][tm-char] module. +Similarly, there is [`Text.Megaparsec.Byte`][tm-byte] module for parsing +streams of bytes. ### Lexer -[`Text.Megaparsec.Char.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char-Lexer.html) -is a module that should help you write your lexer. If you have used `Parsec` -in the past, this module “fixes” its particularly inflexible -`Text.Parsec.Token`. - -`Text.Megaparsec.Char.Lexer` is intended to be imported using a qualified -import, it's not included in `Text.Megaparsec`. The module doesn't impose -how you should write your parser, but certain approaches may be more elegant -than others. An especially important theme is parsing of white space, -comments, and indentation. +[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is a module that should help +you write your lexer. If you have used `Parsec` in the past, this module +“fixes” its particularly inflexible `Text.Parsec.Token`. -The design of the module allows you quickly solve simple tasks and doesn't -get in your way when you want to implement something less standard. +[`Text.Megaparsec.Char.Lexer`][tm-char-lexer] is intended to be imported +using a qualified import, it's not included in [`Text.Megaparsec`][tm]. The +module doesn't impose how you should write your parser, but certain +approaches may be more elegant than others. An especially important theme is +parsing of white space, comments, and indentation. -Since Megaparsec 5, all tools for indentation-sensitive parsing are -available in `Text.Megaparsec.Char.Lexer` module—no third party packages -required. +The design of the module allows one quickly solve simple tasks and doesn't +get in the way when the need to implement something less standard arises. -`Text.Megaparsec.Byte.Lexer` is also available for users who wish to parse -binary data. +[`Text.Megaparsec.Byte.Lexer`][tm-byte-lexer] is also available for users +who wish to parse binary data. ## Documentation Megaparsec is well-documented. See the [current version of Megaparsec -documentation on Hackage](https://hackage.haskell.org/package/megaparsec). +documentation on Hackage][hackage]. ## Tutorials -You can find Megaparsec tutorials -[here](https://markkarpov.com/learn-haskell.html#megaparsec-tutorials). They -should provide sufficient guidance to help you to start with your parsing -tasks. The site also has instructions and tips for Parsec users who decide -to migrate to Megaparsec. +You can find the most complete Megaparsec tutorial [here][the-tutorial]. It +should provide sufficient guidance to help you start with your parsing +tasks. ## Performance -Despite being flexible, Megaparsec is also quite fast. Here is how -Megaparsec 6.4.0 compares to Attoparsec 0.13.2.0 (the fastest widely used -parsing library in the Haskell ecosystem): +Despite being flexible, Megaparsec is also fast. Here is how Megaparsec +compares to [Attoparsec][attoparsec] (the fastest widely used parsing +library in the Haskell ecosystem): Test case | Execution time | Allocated | Max residency ------------------|---------------:|----------:|-------------: -CSV (Attoparsec) | 57.14 μs | 397,912 | 10,560 -CSV (Megaparsec) | 76.27 μs | 557,272 | 9,120 -Log (Attoparsec) | 244.2 μs | 1,181,120 | 11,144 -Log (Megaparsec) | 315.2 μs | 1,485,776 | 11,392 -JSON (Attoparsec) | 14.39 μs | 132,496 | 9,048 -JSON (Megaparsec) | 26.70 μs | 233,336 | 9,424 +CSV (Attoparsec) | 76.50 μs | 397,784 | 10,544 +CSV (Megaparsec) | 64.69 μs | 352,408 | 9,104 +Log (Attoparsec) | 302.8 μs | 1,150,032 | 10,912 +Log (Megaparsec) | 337.8 μs | 1,246,496 | 10,912 +JSON (Attoparsec) | 18.20 μs | 128,368 | 9,032 +JSON (Megaparsec) | 25.45 μs | 203,824 | 9,176 -The benchmarks were created to guide development of Megaparsec 6 and can be -found [here](https://github.com/mrkkrp/parsers-bench). +You can run the benchmarks yourself by executing: -If you think your Megaparsec parser is not efficient enough, take a look at -[these -instructions](https://markkarpov.com/megaparsec/writing-a-fast-parser.html). +``` +$ nix-build -A benches.parsers-bench +$ cd result/bench +$ ./bench-memory +$ ./bench-speed +``` +More information about benchmarking and development can be found +[here][hacking]. + ## Comparison with other solutions There are quite a few libraries that can be used for parsing in Haskell, @@ -200,129 +175,94 @@ ### Megaparsec vs Attoparsec -[Attoparsec](https://github.com/bos/attoparsec) is another prominent Haskell -library for parsing. Although the both libraries deal with parsing, it's -usually easy to decide which you will need in particular project: +[Attoparsec][attoparsec] is another prominent Haskell library for parsing. +Although both libraries deal with parsing, it's usually easy to decide which +you will need in particular project: -* *Attoparsec* is faster but not that feature-rich. It should be used when - you want to process large amounts of data where performance matters more - than quality of error messages. +* *Attoparsec* is sometimes faster but not that feature-rich. It should be + used when you want to process large amounts of data where performance + matters more than quality of error messages. * *Megaparsec* is good for parsing of source code or other human-readable - texts. It has better error messages and it's implemented as monad + texts. It has better error messages and it's implemented as a monad transformer. -So, if you work with something human-readable where size of input data is -usually not huge, just go with Megaparsec, otherwise Attoparsec may be a -better choice. - -Since version 6, Megaparsec features the same fast primitives that -Attoparsec has, so in many cases the difference in speed is not that big. -Megaparsec now aims to be “one size fits all” ultimate solution to parsing, -so it can be used even to parse low-level binary formats. +So, if you work with something human-readable where the size of input data +is moderate, it makes sense to go with Megaparsec, otherwise Attoparsec may +be a better choice. ### Megaparsec vs Parsec -Since Megaparsec is a fork of Parsec, we are bound to list the main -differences between the two libraries: +Since Megaparsec is a fork of [Parsec][parsec], we are bound to list the +main differences between the two libraries: -* Better error messages. We test our error messages using numerous - QuickCheck (generative) tests. Good error messages are just as important - for us as correct return values of our parsers. Megaparsec will be - especially useful if you write a compiler or an interpreter for some - language. +* Better error messages. Megaparsec has typed error messages and custom + error messages, it can also report multiple parse errors at once. -* Megaparsec 6 can show the line on which parse error happened as part of +* Megaparsec can show the line on which parse error happened as part of parse error. This makes it a lot easier to figure out where the error happened. -* Some quirks and “buggy features” (as well as plain bugs) of original - Parsec are fixed. There is no undocumented surprising stuff in Megaparsec. +* Some quirks and bugs of Parsec are fixed. -* Better support for Unicode parsing in `Text.Megaparsec.Char`. +* Better support for Unicode parsing in [`Text.Megaparsec.Char`][tm-char]. * Megaparsec has more powerful combinators and can parse languages where - indentation matters out-of-the-box. - -* Comprehensive test suite covering nearly 100% of our code. Compare that to - absence - -* We have benchmarks to detect performance regressions. - -* Better documentation, with 100% of functions covered, without typos and - obsolete information, with working examples. Megaparsec's documentation is - well-structured and doesn't contain things useless to end users. - -* Megaparsec's code is clearer and doesn't contain “magic” found in original - Parsec. + indentation matters. -* Megaparsec has well-typed error messages and custom error messages. +* Better documentation. * Megaparsec can recover from parse errors “on the fly” and continue parsing. -* Megaparsec allows to conditionally process parse errors *inside your - parser* before parsing is finished. In particular, it's possible to define - regions in which parse errors, should they happen, will get a “context - tag”, e.g. we could build a context stack like “in function definition - foo”, “in expression x”, etc. This is not possible with Parsec. +* Megaparsec allows us to conditionally process parse errors inside a + running parser. In particular, it's possible to define regions in which + parse errors, should they happen, will get a “context tag”, e.g. we could + build a context stack like “in function definition foo”, “in expression + x”, etc. -* Megaparsec is faster and supports efficient operations on top of `tokens`, - `takeWhileP`, `takeWhile1P`, `takeP` like Attoparsec. +* Megaparsec is faster and supports efficient operations `tokens`, + `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec. If you want to see a detailed change log, `CHANGELOG.md` may be helpful. -Also see [this original announcement](https://notehub.org/w7037) for another +Also see [this original announcement][original-announcement] for another comparison. ### Megaparsec vs Trifecta -[Trifecta](https://hackage.haskell.org/package/trifecta) is another Haskell -library featuring good error messages. It's probably good, but also -under-documented, and has unfixed [bugs and -flaws](https://github.com/ekmett/trifecta/issues). Other reasons one may -question choice of Trifecta is his/her parsing library: +[Trifecta][trifecta] is another Haskell library featuring good error +messages. These are the common reasons why Trifecta may be problematic to +use: * Complicated, doesn't have any tutorials available, and documentation - doesn't help at all. + doesn't help much. * Trifecta can parse `String` and `ByteString` natively, but not `Text`. -* Trifecta's error messages may be different with their own features, but - certainly not as flexible as Megaparsec's error messages in the latest - versions. - -* Depends on `lens`. This means you'll pull in half of Hackage as transitive - dependencies. Also if you're not into `lens` and would like to keep your - code “vanilla”, you may not like the API. +* Depends on `lens`, which is a very heavy dependency. If you're not into + `lens`, you may not like the API. -[Idris](https://www.idris-lang.org/) has recently switched from Trifecta to -Megaparsec which allowed it to [have better error messages and fewer -dependencies](https://twitter.com/edwinbrady/status/950084043282010117?s=09). +[Idris][idris] has switched from Trifecta to Megaparsec which allowed it to +[have better error messages and fewer dependencies][idris-testimony]. ### Megaparsec vs Earley -[Earley](https://hackage.haskell.org/package/Earley) is a newer library that -allows to safely (it your code compiles, then it probably works) parse +[Earley][earley] is a newer library that allows us to safely parse context-free grammars (CFG). Megaparsec is a lower-level library compared to -Earley, but there are still enough reasons to choose it over Earley: +Earley, but there are still enough reasons to choose it: * Megaparsec is faster. * Your grammar may be not context-free or you may want introduce some sort of state to the parsing process. Almost all non-trivial parsers require - something of this sort. Even if your grammar is context-free, state may - allow to add some additional niceties. Earley does not support that. + state. Even if your grammar is context-free, state may allow for + additional niceties. Earley does not support that. * Megaparsec's error messages are more flexible allowing to include arbitrary data in them, return multiple error messages, mark regions that affect any error that happens in those regions, etc. -* The approach Earley uses differs from the conventional monadic parsing. If - you work not alone, people you work with, especially beginners, will be - much more productive with libraries taking more traditional path to - parsing like Megaparsec. - -IOW, Megaparsec is less safe but also more powerful. +In other words, Megaparsec is less safe but also more powerful. ## Related packages @@ -332,6 +272,8 @@ * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities for testing Megaparsec parsers with with [Hspec](https://hackage.haskell.org/package/hspec). +* [`replace-megaparsec`](https://hackage.haskell.org/package/replace-megaparsec)—Stream + editing and find-and-replace with Megaparsec. * [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec)—Megaparsec parser of CSV files that plays nicely with [Cassava](https://hackage.haskell.org/package/cassava). @@ -339,53 +281,72 @@ library for easily using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in Megaparsec. +* [`parser-combinators`](https://hackage.haskell.org/package/parser-combinators)—provides permutation and expression parsers [previously bundled with Megaparsec](https://markkarpov.com/post/megaparsec-7.html#parsercombinators-grows-megaparsec-shrinks). +* [`faster-megaparsec`](https://hackage.haskell.org/package/faster-megaparsec)—speeds up parsing + by trying a simple `MonadParsec` instance and falls back to `ParsecT` to report errors. ## Prominent projects that use Megaparsec -The following are some prominent projects that use Megaparsec: +Some prominent projects that use Megaparsec: * [Idris](https://github.com/idris-lang/Idris-dev)—a general-purpose functional programming language with dependent types +* [Dhall](https://github.com/dhall-lang/dhall-haskell)—an advanced + configuration language +* [hnix](https://github.com/haskell-nix/hnix)—re-implementation of the Nix + language in Haskell * [Hledger](https://github.com/simonmichael/hledger)—an accounting tool * [MMark](https://github.com/mmark-md/mmark)—strict markdown processor for writers -* [Stache](https://github.com/stackbuilders/stache)—Mustache templates for - Haskell -* [Language Puppet](https://github.com/bartavelle/language-puppet)—library - for manipulating Puppet manifests ## Links to announcements and blog posts Here are some blog posts mainly announcing new features of the project and describing what sort of things are now possible: +* [Megaparsec 8](https://markkarpov.com/post/megaparsec-8.html) +* [Megaparsec 7](https://markkarpov.com/post/megaparsec-7.html) * [Evolution of error messages](https://markkarpov.com/post/evolution-of-error-messages.html) * [A major upgrade to Megaparsec: more speed, more power](https://markkarpov.com/post/megaparsec-more-speed-more-power.html) * [Latest additions to Megaparsec](https://markkarpov.com/post/latest-additions-to-megaparsec.html) * [Announcing Megaparsec 5](https://markkarpov.com/post/announcing-megaparsec-5.html) * [Megaparsec 4 and 5](https://markkarpov.com/post/megaparsec-4-and-5.html) -* [The original Megaparsec 4.0.0 announcement](https://notehub.org/w7037) - -## Authors - -The project was started and is currently maintained by Mark Karpov. You can -find the complete list of contributors in the `AUTHORS.md` file in the -official repository of the project. Thanks to all the people who propose -features and ideas, although they are not in `AUTHORS.md`, without them -Megaparsec would not be that good. +* [The original Megaparsec 4.0.0 announcement][original-announcement] ## Contribution Issues (bugs, feature requests or otherwise feedback) may be reported in -[the GitHub issue tracker for this project](https://github.com/mrkkrp/megaparsec/issues). +[the GitHub issue tracker for this +project](https://github.com/mrkkrp/megaparsec/issues). -Pull requests are also welcome (and yes, they will get attention and will be -merged quickly if they are good). +Pull requests are also welcome. If you would like to contribute to the +project, you may find [this document][hacking] helpful. ## License -Copyright © 2015–2018 Megaparsec contributors\ +Copyright © 2015–present Megaparsec contributors\ Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen Distributed under FreeBSD license. + +[hackage]: https://hackage.haskell.org/package/megaparsec +[the-tutorial]: https://markkarpov.com/tutorial/megaparsec.html +[hacking]: ./HACKING.md + +[tm]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec.html +[tm-char]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html +[tm-byte]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte.html +[tm-char-lexer]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char-Lexer.html +[tm-byte-lexer]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte-Lexer.html + +[attoparsec]: https://hackage.haskell.org/package/attoparsec +[parsec]: https://hackage.haskell.org/package/parsec +[trifecta]: https://hackage.haskell.org/package/trifecta +[earley]: https://hackage.haskell.org/package/Earley +[idris]: https://www.idris-lang.org/ +[idris-testimony]: https://twitter.com/edwinbrady/status/950084043282010117?s=09 + +[parsers-bench]: https://github.com/mrkkrp/parsers-bench +[fast-parser]: https://markkarpov.com/megaparsec/writing-a-fast-parser.html +[original-announcement]: https://mail.haskell.org/pipermail/haskell-cafe/2015-September/121530.html 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–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -11,10 +20,10 @@ -- -- This module includes everything you need to get started writing a parser. -- If you are new to Megaparsec and don't know where to begin, take a look --- at the tutorials . +-- at the tutorial . -- -- In addition to the "Text.Megaparsec" module, which exports and re-exports --- most everything that you may need, we advise to import +-- almost everything that you may need, we advise to import -- "Text.Megaparsec.Char" if you plan to work with a stream of 'Char' tokens -- or "Text.Megaparsec.Byte" if you intend to parse binary data. -- @@ -24,125 +33,113 @@ -- > type Parser = Parsec Void Text -- > ^ ^ -- > | | --- > Custom error component Type of input +-- > Custom error component Input stream type -- --- Then you can write type signatures like @Parser Int@—for a parser that +-- Then you can write type signatures like @Parser 'Int'@—for a parser that -- returns an 'Int' for example. -- -- Similarly (since it's known to cause confusion), you should use --- 'ParseError' type parametrized like this: --- --- > ParseError Char Void --- > ^ ^ --- > | | --- > Token type Custom error component (the same you used in Parser) +-- 'ParseErrorBundle' type parametrized like this: -- --- Token type for 'String' and 'Data.Text.Text' (strict and lazy) is 'Char', --- for 'Data.ByteString.ByteString's it's 'Data.Word.Word8'. +-- > ParseErrorBundle Text Void +-- > ^ ^ +-- > | | +-- > Input stream type Custom error component (the same you used in Parser) -- -- Megaparsec uses some type-level machinery to provide flexibility without -- compromising on type safety. Thus type signatures are sometimes necessary --- to avoid ambiguous types. If you're seeing a error message that reads +-- to avoid ambiguous types. If you're seeing an error message that reads -- like “Type variable @e0@ is ambiguous …”, you need to give an explicit -- signature to your parser to resolve the ambiguity. It's a good idea to -- provide type signatures for all top-level definitions. --- --- Megaparsec is capable of a lot. Apart from this standard functionality --- you can parse permutation phrases with "Text.Megaparsec.Perm", --- expressions with "Text.Megaparsec.Expr", do lexing with --- "Text.Megaparsec.Char.Lexer" and "Text.Megaparsec.Byte.Lexer". These --- modules should be imported explicitly along with the modules mentioned --- above. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec ( -- * Re-exports -- $reexports - module Text.Megaparsec.Pos - , module Text.Megaparsec.Error - , module Text.Megaparsec.Stream - , module Control.Monad.Combinators + module Text.Megaparsec.Pos, + module Text.Megaparsec.Error, + module Text.Megaparsec.Stream, + module Control.Monad.Combinators, + -- * Data types - , State (..) - , Parsec - , ParsecT + State (..), + PosState (..), + Parsec, + ParsecT, + -- * Running parser - , parse - , parseMaybe - , parseTest - , parseTest' - , runParser - , runParser' - , runParserT - , runParserT' + parse, + parseMaybe, + parseTest, + runParser, + runParser', + runParserT, + runParserT', + -- * Primitive combinators - , MonadParsec (..) + MonadParsec (..), + + -- * Signaling parse errors + -- $parse-errors + failure, + fancyFailure, + unexpected, + customFailure, + region, + registerParseError, + registerFailure, + registerFancyFailure, + -- * Derivatives of primitive combinators - , () - , unexpected - , customFailure - , match - , region - , takeRest - , atEnd + single, + satisfy, + anySingle, + anySingleBut, + oneOf, + noneOf, + chunk, + (), + match, + takeRest, + atEnd, + -- * Parser state combinators - , getInput - , setInput - , getPosition - , getNextTokenPosition - , setPosition - , pushPosition - , popPosition - , getTokensProcessed - , setTokensProcessed - , getTabWidth - , setTabWidth - , setParserState - -- * Debugging - , dbg ) + getInput, + setInput, + getSourcePos, + getOffset, + setOffset, + setParserState, + ) where -import Control.Monad import Control.Monad.Combinators import Control.Monad.Identity import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust) -import Data.Proxy -import Debug.Trace +import Data.Set (Set) +import qualified Data.Set as E import Text.Megaparsec.Class import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif - -- $reexports -- -- Note that we re-export monadic combinators from -- "Control.Monad.Combinators" because these are more efficient than --- 'Applicative'-based ones. Thus 'many' and 'some' may clash with the +-- 'Applicative'-based ones (†). Thus 'many' and 'some' may clash with the -- functions from "Control.Applicative". You need to hide the functions like -- this: -- -- > import Control.Applicative hiding (many, some) -- +-- † As of Megaparsec 9.7.0 'Control.Applicative.many' and +-- 'Control.Applicative.some' are as efficient as their monadic +-- counterparts. +-- -- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you -- wish that combinators like 'some' return 'NonEmpty' lists. The module -- lives in the @parser-combinators@ package (you need at least version @@ -151,36 +148,46 @@ -- This module is intended to be imported qualified: -- -- > import qualified Control.Monad.Combinators.NonEmpty as NE +-- +-- Other modules of interest are: +-- +-- * "Control.Monad.Combinators.Expr" for parsing of expressions. +-- * "Control.Applicative.Permutations" for parsing of permutations +-- phrases. ---------------------------------------------------------------------------- -- Data types -- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' -- monad transformer. - type Parsec e s = ParsecT e s Identity ---------------------------------------------------------------------------- -- Running a parser --- | @'parse' p file input@ runs parser @p@ over 'Identity' (see 'runParserT' --- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a --- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn --- 'ParseError' into the string representation of the error message. See --- "Text.Megaparsec.Error" if you need to do more advanced error analysis. +-- | @'parse' p file input@ runs parser @p@ over 'Identity' (see +-- 'runParserT' if you're using the 'ParsecT' monad transformer; 'parse' +-- itself is just a synonym for 'runParser'). It returns either a +-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). +-- 'errorBundlePretty' can be used to turn 'ParseErrorBundle' into the +-- string representation of the error message. See "Text.Megaparsec.Error" +-- if you need to do more advanced error analysis. -- --- > main = case (parse numbers "" "11,2,43") of --- > Left err -> putStr (parseErrorPretty err) +-- > main = case parse numbers "" "11,2,43" of +-- > Left bundle -> putStr (errorBundlePretty bundle) -- > Right xs -> print (sum xs) -- > --- > numbers = integer `sepBy` char ',' - -parse - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a +-- > numbers = decimal `sepBy` char ',' +-- +-- 'parse' is the same as 'runParser'. +parse :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a parse = runParser -- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the @@ -189,423 +196,469 @@ -- will fail. -- -- The function is supposed to be useful for lightweight parsing, where --- error messages (and thus file name) are not important and entire input --- should be parsed. For example, it can be used when parsing of a single --- number according to a specification of its format is desired. - +-- error messages (and thus file names) are not important and entire input +-- should be consumed. For example, it can be used for parsing of a single +-- number according to a specification of its format. parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s = case parse (p <* eof) "" s of - Left _ -> Nothing + Left _ -> Nothing Right x -> Just x --- | The expression @'parseTest' p input@ applies the parser @p@ against +-- | The expression @'parseTest' p input@ applies the parser @p@ on the -- input @input@ and prints the result to stdout. Useful for testing. - -parseTest :: ( ShowErrorComponent e - , Ord (Token s) - , ShowToken (Token s) - , Show a ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () +parseTest :: + ( ShowErrorComponent e, + Show a, + VisualStream s, + TraversableStream s + ) => + -- | Parser to run + Parsec e s a -> + -- | Input for parser + s -> + IO () parseTest p input = case parse p "" input of - Left e -> putStr (parseErrorPretty e) - Right x -> print x - --- | A version of 'parseTest' that also prints offending line in parse --- errors. --- --- @since 6.0.0 - -parseTest' :: ( ShowErrorComponent e - , ShowToken (Token s) - , LineToken (Token s) - , Show a - , Stream s ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () -parseTest' p input = - case parse p "" input of - Left e -> putStr (parseErrorPretty' input e) + Left e -> putStr (errorBundlePretty e) Right x -> print x -- | @'runParser' p file input@ runs parser @p@ on the input stream of -- tokens @input@, obtained from source @file@. The @file@ is only used in --- error messages and may be the empty string. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). +-- error messages and may be the empty string. Returns either a +-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file - -runParser - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a +-- +-- 'runParser' is the same as 'parse'. +runParser :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a runParser p name s = snd $ runParser' p (initialState name s) -- | The function is similar to 'runParser' with the difference that it --- accepts and returns parser state. This allows to specify arbitrary --- textual position at the beginning of parsing, for example. This is the --- most general way to run a parser over the 'Identity' monad. +-- accepts and returns the parser state. This allows us e.g. to specify +-- arbitrary textual position at the beginning of parsing. This is the most +-- general way to run a parser over the 'Identity' monad. -- -- @since 4.2.0 - -runParser' - :: Parsec e s a -- ^ Parser to run - -> State s -- ^ Initial state - -> (State s, Either (ParseError (Token s) e) a) +runParser' :: + -- | Parser to run + Parsec e s a -> + -- | Initial state + State s e -> + (State s e, Either (ParseErrorBundle s e) a) runParser' p = runIdentity . runParserT' p -- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns a computation in the --- underlying monad @m@ that returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). - -runParserT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> m (Either (ParseError (Token s) e) a) -runParserT p name s = snd `liftM` runParserT' p (initialState name s) +-- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or +-- a value of type @a@ ('Right'). +runParserT :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + m (Either (ParseErrorBundle s e) a) +runParserT p name s = snd <$> runParserT' p (initialState name s) -- | This function is similar to 'runParserT', but like 'runParser'' it -- accepts and returns parser state. This is thus the most general way to -- run a parser. -- -- @since 4.2.0 - -runParserT' :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (State s, Either (ParseError (Token s) e) a) +runParserT' :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Initial state + State s e -> + m (State s e, Either (ParseErrorBundle s e) a) runParserT' p s = do (Reply s' _ result) <- runParsecT p s - case result of - OK x -> return (s', Right x) - Error e -> return (s', Left e) - --- | Given name of source file and input construct initial state for parser. - -initialState :: String -> s -> State s -initialState name s = State - { stateInput = s - , statePos = initialPos name :| [] - , stateTokensProcessed = 0 - , stateTabWidth = defaultTabWidth } + let toBundle es = + ParseErrorBundle + { bundleErrors = + NE.sortWith errorOffset es, + bundlePosState = statePosState s + } + return $ case result of + OK _ x -> + case NE.nonEmpty (stateParseErrors s') of + Nothing -> (s', Right x) + Just de -> (s', Left (toBundle de)) + Error e -> + (s', Left (toBundle (e :| stateParseErrors s'))) ---------------------------------------------------------------------------- --- Derivatives of primitive combinators +-- Signaling parse errors --- | A synonym for 'label' in the form of an operator. +-- $parse-errors +-- +-- The most general function to fail and end parsing is 'parseError'. These +-- are built on top of it. The section also includes functions starting with +-- the @register@ prefix which allow users to register “delayed” +-- 'ParseError's. -infix 0 +-- | Stop parsing and report a trivial 'ParseError'. +-- +-- @since 6.0.0 +failure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m a +failure us ps = do + o <- getOffset + parseError (TrivialError o us ps) +{-# INLINE failure #-} -() :: MonadParsec e s m => m a -> String -> m a -() = flip label -{-# INLINE () #-} +-- | Stop parsing and report a fancy 'ParseError'. To report a single custom +-- parse error, see 'Text.Megaparsec.customFailure'. +-- +-- @since 6.0.0 +fancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m a +fancyFailure xs = do + o <- getOffset + parseError (FancyError o xs) +{-# INLINE fancyFailure #-} -- | The parser @'unexpected' item@ fails with an error message telling -- about unexpected item @item@ without consuming any input. -- --- > unexpected item = failure (pure item) Set.empty - -unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a -unexpected item = failure (pure item) E.empty +-- > unexpected item = failure (Just item) Set.empty +unexpected :: (MonadParsec e s m) => ErrorItem (Token s) -> m a +unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-} -- | Report a custom parse error. For a more general version, see -- 'fancyFailure'. -- +-- > customFailure = fancyFailure . Set.singleton . ErrorCustom +-- -- @since 6.3.0 - -customFailure :: MonadParsec e s m => e -> m a +customFailure :: (MonadParsec e s m) => e -> m a customFailure = fancyFailure . E.singleton . ErrorCustom {-# INLINE customFailure #-} --- | Return both the result of a parse and a chunk of input that was --- consumed during parsing. This relies on the change of the --- 'stateTokensProcessed' value to evaluate how many tokens were consumed. --- If you mess with it manually in the argument parser, prepare for --- troubles. --- --- @since 5.3.0 - -match :: MonadParsec e s m => m a -> m (Tokens s, a) -match p = do - tp <- getTokensProcessed - s <- getInput - r <- p - tp' <- getTokensProcessed - -- NOTE The 'fromJust' call here should never fail because if the stream - -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing' - -- as per its invariants), (tp' - tp) won't be greater than 0, and in that - -- case 'Just' is guaranteed to be returned as per another invariant of - -- 'takeN_'. - return ((fst . fromJust) (takeN_ (tp' - tp) s), r) -{-# INLINEABLE match #-} - -- | Specify how to process 'ParseError's that happen inside of this --- wrapper. As a side effect of the current implementation changing --- 'errorPos' with this combinator will also change the final 'statePos' in --- the parser state (try to avoid that because 'statePos' will go out of --- sync with factual position in the input stream, which is probably OK if --- you finish parsing right after that, but be warned). +-- wrapper. This applies to both normal and delayed 'ParseError's. -- +-- As a side-effect of the implementation the inner computation will start +-- with an empty collection of delayed errors and they will be updated and +-- “restored” on the way out of 'region'. +-- -- @since 5.3.0 - -region :: MonadParsec e s m - => (ParseError (Token s) e -> ParseError (Token s) e) - -- ^ How to process 'ParseError's - -> m a -- ^ The “region” that the processing applies to - -> m a +region :: + (MonadParsec e s m) => + -- | How to process 'ParseError's + (ParseError s e -> ParseError s e) -> + -- | The “region” that the processing applies to + m a -> + m a region f m = do + deSoFar <- stateParseErrors <$> getParserState + updateParserState $ \s -> + s {stateParseErrors = []} r <- observing m + updateParserState $ \s -> + s {stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar} case r of - Left err -> - case f err of - TrivialError pos us ps -> do - updateParserState $ \st -> st { statePos = pos } - failure us ps - FancyError pos xs -> do - updateParserState $ \st -> st { statePos = pos } - fancyFailure xs + Left err -> parseError (f err) Right x -> return x {-# INLINEABLE region #-} --- | Consume the rest of the input and return it as a chunk. This parser --- never fails, but may return an empty chunk. --- --- > takeRest = takeWhileP Nothing (const True) +-- | Register a 'ParseError' for later reporting. This action does not end +-- parsing and has no effect except for adding the given 'ParseError' to the +-- collection of “delayed” 'ParseError's which will be taken into +-- consideration at the end of parsing. Only if this collection is empty will +-- the parser succeed. This is the main way to report several parse errors +-- at once. -- --- @since 6.0.0 - -takeRest :: MonadParsec e s m => m (Tokens s) -takeRest = takeWhileP Nothing (const True) -{-# INLINE takeRest #-} +-- @since 8.0.0 +registerParseError :: (MonadParsec e s m) => ParseError s e -> m () +registerParseError e = updateParserState $ \s -> + s {stateParseErrors = e : stateParseErrors s} +{-# INLINE registerParseError #-} --- | Return 'True' when end of input has been reached. +-- | Like 'failure', but for delayed 'ParseError's. -- --- @since 6.0.0 +-- @since 8.0.0 +registerFailure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m () +registerFailure us ps = do + o <- getOffset + registerParseError (TrivialError o us ps) +{-# INLINE registerFailure #-} -atEnd :: MonadParsec e s m => m Bool -atEnd = option False (True <$ hidden eof) -{-# INLINE atEnd #-} +-- | Like 'fancyFailure', but for delayed 'ParseError's. +-- +-- @since 8.0.0 +registerFancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m () +registerFancyFailure xs = do + o <- getOffset + registerParseError (FancyError o xs) +{-# INLINE registerFancyFailure #-} ---------------------------------------------------------------------------- --- Parser state combinators - --- | Return the current input. - -getInput :: MonadParsec e s m => m s -getInput = stateInput <$> getParserState - --- | @'setInput' input@ continues parsing with @input@. The 'getInput' and --- 'setInput' functions can for example be used to deal with include files. - -setInput :: MonadParsec e s m => s -> m () -setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w) +-- Derivatives of primitive combinators --- | Return the current source position. +-- | @'single' t@ only matches the single token @t@. -- --- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'. - -getPosition :: MonadParsec e s m => m SourcePos -getPosition = NE.head . statePos <$> getParserState - --- | Get the position where the next token in the stream begins. If the --- stream is empty, return 'Nothing'. +-- > semicolon = single ';' -- --- @since 5.3.0 - -getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos) -getNextTokenPosition = do - State {..} <- getParserState - let f = positionAt1 (Proxy :: Proxy s) (NE.head statePos) - return (f . fst <$> take1_ stateInput) -{-# INLINEABLE getNextTokenPosition #-} - --- | @'setPosition' pos@ sets the current source position to @pos@. +-- See also: 'token', 'anySingle', 'Text.Megaparsec.Byte.char', +-- 'Text.Megaparsec.Char.char'. -- --- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. - -setPosition :: MonadParsec e s m => SourcePos -> m () -setPosition pos = updateParserState $ \(State s (_:|z) tp w) -> - State s (pos:|z) tp w +-- @since 7.0.0 +single :: + (MonadParsec e s m) => + -- | Token to match + Token s -> + m (Token s) +single t = token testToken expected + where + testToken x = if x == t then Just x else Nothing + expected = E.singleton (Tokens (t :| [])) +{-# INLINE single #-} --- | Push a position into stack of positions and continue parsing working --- with this position. Useful for working with include files and the like. +-- | The parser @'satisfy' f@ succeeds for any token for which the supplied +-- function @f@ returns 'True'. -- --- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'. +-- > digitChar = satisfy isDigit "digit" +-- > oneOf cs = satisfy (`elem` cs) -- --- @since 5.0.0 - -pushPosition :: MonadParsec e s m => SourcePos -> m () -pushPosition pos = updateParserState $ \(State s z tp w) -> - State s (NE.cons pos z) tp w - --- | Pop a position from the stack of positions unless it only contains one --- element (in that case the stack of positions remains the same). This is --- how to return to previous source file after 'pushPosition'. +-- __Performance note__: when you need to parse a single token, it is often +-- a good idea to use 'satisfy' with the right predicate function instead of +-- creating a complex parser using the combinators. -- --- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'. +-- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'. -- --- @since 5.0.0 - -popPosition :: MonadParsec e s m => m () -popPosition = updateParserState $ \(State s z tp w) -> - case snd (NE.uncons z) of - Nothing -> State s z tp w - Just z' -> State s z' tp w +-- @since 7.0.0 +satisfy :: + (MonadParsec e s m) => + -- | Predicate to apply + (Token s -> Bool) -> + m (Token s) +satisfy f = token testChar E.empty + where + testChar x = if f x then Just x else Nothing +{-# INLINE satisfy #-} --- | Get the number of tokens processed so far. +-- | Parse and return a single token. It's a good idea to attach a 'label' +-- to this parser. -- --- @since 6.0.0 - -getTokensProcessed :: MonadParsec e s m => m Int -getTokensProcessed = stateTokensProcessed <$> getParserState - --- | Set the number of tokens processed so far. +-- > anySingle = satisfy (const True) -- --- @since 6.0.0 - -setTokensProcessed :: MonadParsec e s m => Int -> m () -setTokensProcessed tp = updateParserState $ \(State s pos _ w) -> - State s pos tp w - --- | Return the tab width. The default tab width is equal to --- 'defaultTabWidth'. You can set a different tab width with the help of --- 'setTabWidth'. - -getTabWidth :: MonadParsec e s m => m Pos -getTabWidth = stateTabWidth <$> getParserState - --- | Set tab width. If the argument of the function is not a positive --- number, 'defaultTabWidth' will be used. - -setTabWidth :: MonadParsec e s m => Pos -> m () -setTabWidth w = updateParserState $ \(State s pos tp _) -> - State s pos tp w - --- | @'setParserState' st@ sets the parser state to @st@. +-- See also: 'satisfy', 'anySingleBut'. +-- +-- @since 7.0.0 +anySingle :: (MonadParsec e s m) => m (Token s) +anySingle = satisfy (const True) +{-# INLINE anySingle #-} -setParserState :: MonadParsec e s m => State s -> m () -setParserState st = updateParserState (const st) +-- | Match any token but the given one. It's a good idea to attach a 'label' +-- to this parser. +-- +-- > anySingleBut t = satisfy (/= t) +-- +-- See also: 'single', 'anySingle', 'satisfy'. +-- +-- @since 7.0.0 +anySingleBut :: + (MonadParsec e s m) => + -- | Token we should not match + Token s -> + m (Token s) +anySingleBut t = satisfy (/= t) +{-# INLINE anySingleBut #-} ----------------------------------------------------------------------------- --- Debugging +-- | @'oneOf' ts@ succeeds if the current token is in the supplied +-- collection of tokens @ts@. Returns the parsed token. Note that this +-- parser cannot automatically generate the “expected” component of error +-- message, so usually you should label it manually with 'label' or (''). +-- +-- > oneOf cs = satisfy (`elem` cs) +-- +-- See also: 'satisfy'. +-- +-- > digit = oneOf ['0'..'9'] "digit" +-- +-- __Performance note__: prefer 'satisfy' when you can because it's faster +-- when you have only a couple of tokens to compare to: +-- +-- > quoteFast = satisfy (\x -> x == '\'' || x == '\"') +-- > quoteSlow = oneOf "'\"" +-- +-- @since 7.0.0 +oneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of matching tokens + f (Token s) -> + m (Token s) +oneOf cs = satisfy (\x -> elem x cs) +{-# INLINE oneOf #-} --- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated --- it also prints information useful for debugging. The @label@ is only used --- to refer to this parser in the debugging output. This combinator uses the --- 'trace' function from "Debug.Trace" under the hood. +-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token is +-- /not/ in the supplied list of tokens @ts@. Returns the parsed character. +-- Note that this parser cannot automatically generate the “expected” +-- component of error message, so usually you should label it manually with +-- 'label' or (''). -- --- Typical usage is to wrap every sub-parser in misbehaving parser with --- 'dbg' assigning meaningful labels. Then give it a shot and go through the --- print-out. As of current version, this combinator prints all available --- information except for /hints/, which are probably only interesting to --- the maintainer of Megaparsec itself and may be quite verbose to output in --- general. Let me know if you would like to be able to see hints in the --- debugging output. +-- > noneOf cs = satisfy (`notElem` cs) -- --- The output itself is pretty self-explanatory, although the following --- abbreviations should be clarified (they are derived from the low-level --- source code): +-- See also: 'satisfy'. -- --- * @COK@—“consumed OK”. The parser consumed input and succeeded. --- * @CERR@—“consumed error”. The parser consumed input and failed. --- * @EOK@—“empty OK”. The parser succeeded without consuming input. --- * @EERR@—“empty error”. The parser failed without consuming input. +-- __Performance note__: prefer 'satisfy' and 'anySingleBut' when you can +-- because it's faster. -- --- Finally, it's not possible to lift this function into some monad --- transformers without introducing surprising behavior (e.g. unexpected --- state backtracking) or adding otherwise redundant constraints (e.g. --- 'Show' instance for state), so this helper is only available for --- 'ParsecT' monad, not 'MonadParsec' in general. +-- @since 7.0.0 +noneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of tokens we should not match + f (Token s) -> + m (Token s) +noneOf cs = satisfy (\x -> notElem x cs) +{-# INLINE noneOf #-} + +-- | @'chunk' chk@ only matches the chunk @chk@. -- --- @since 5.1.0 +-- > divOrMod = chunk "div" <|> chunk "mod" +-- +-- See also: 'tokens', 'Text.Megaparsec.Char.string', +-- 'Text.Megaparsec.Byte.string'. +-- +-- @since 7.0.0 +chunk :: + (MonadParsec e s m) => + -- | Chunk to match + Tokens s -> + m (Tokens s) +chunk = tokens (==) +{-# INLINE chunk #-} -dbg :: forall e s m a. - ( Stream s - , ShowToken (Token s) - , ShowErrorComponent e - , Show a ) - => String -- ^ Debugging label - -> ParsecT e s m a -- ^ Parser to debug - -> ParsecT e s m a -- ^ Parser that prints debugging messages -dbg lbl p = ParsecT $ \s cok cerr eok eerr -> - let l = dbgLog lbl :: DbgItem s e a -> String - unfold = streamTake 40 - cok' x s' hs = flip trace (cok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x) - cerr' err s' = flip trace (cerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err) - eok' x s' hs = flip trace (eok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x) - eerr' err s' = flip trace (eerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err) - in unParser p s cok' cerr' eok' eerr' +-- | A synonym for 'label' in the form of an operator. +infix 0 --- | A single piece of info to be rendered with 'dbgLog'. +() :: (MonadParsec e s m) => m a -> String -> m a +() = flip label +{-# INLINE () #-} -data DbgItem s e a - = DbgIn [Token s] - | DbgCOK [Token s] a - | DbgCERR [Token s] (ParseError (Token s) e) - | DbgEOK [Token s] a - | DbgEERR [Token s] (ParseError (Token s) e) +-- | Return both the result of a parse and a chunk of input that was +-- consumed during parsing. This relies on the change of the 'stateOffset' +-- value to evaluate how many tokens were consumed. If you mess with it +-- manually in the argument parser, prepare for troubles. +-- +-- @since 5.3.0 +match :: (MonadParsec e s m) => m a -> m (Tokens s, a) +match p = do + o <- getOffset + s <- getInput + r <- p + o' <- getOffset + -- NOTE The 'fromJust' call here should never fail because if the stream + -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing' + -- as per its invariants), (tp' - tp) won't be greater than 0, and in that + -- case 'Just' is guaranteed to be returned as per another invariant of + -- 'takeN_'. + return ((fst . fromJust) (takeN_ (o' - o) s), r) +{-# INLINEABLE match #-} --- | Render a single piece of debugging info. +-- | Consume the rest of the input and return it as a chunk. This parser +-- never fails, but may return the empty chunk. +-- +-- > takeRest = takeWhileP Nothing (const True) +-- +-- @since 6.0.0 +takeRest :: (MonadParsec e s m) => m (Tokens s) +takeRest = takeWhileP Nothing (const True) +{-# INLINE takeRest #-} -dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s)) - => String -- ^ Debugging label - -> DbgItem s e a -- ^ Information to render - -> String -- ^ Rendered result -dbgLog lbl item = prefix msg - where - prefix = unlines . fmap ((lbl ++ "> ") ++) . lines - msg = case item of - DbgIn ts -> - "IN: " ++ showStream ts - DbgCOK ts a -> - "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a - DbgCERR ts e -> - "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e - DbgEOK ts a -> - "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a - DbgEERR ts e -> - "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e +-- | Return 'True' when end of input has been reached. +-- +-- > atEnd = option False (True <$ hidden eof) +-- +-- @since 6.0.0 +atEnd :: (MonadParsec e s m) => m Bool +atEnd = option False (True <$ hidden eof) +{-# INLINE atEnd #-} --- | Pretty-print a list of tokens. +---------------------------------------------------------------------------- +-- Parser state combinators -showStream :: ShowToken t => [t] -> String -showStream ts = - case NE.nonEmpty ts of - Nothing -> "" - Just ne -> - let (h, r) = splitAt 40 (showTokens ne) - in if null r then h else h ++ " <…>" +-- | Return the current input. +getInput :: (MonadParsec e s m) => m s +getInput = stateInput <$> getParserState +{-# INLINE getInput #-} --- | Calculate number of consumed tokens given 'State' of parser before and --- after parsing. +-- | @'setInput' input@ continues parsing with @input@. +setInput :: (MonadParsec e s m) => s -> m () +setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) +{-# INLINE setInput #-} -streamDelta - :: State s -- ^ State of parser before consumption - -> State s -- ^ State of parser after consumption - -> Int -- ^ Number of consumed tokens -streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0 +-- | Return the current source position. This function /is not cheap/, do +-- not call it e.g. on matching of every token, that's a bad idea. Still you +-- can use it to get 'SourcePos' to attach to things that you parse. +-- +-- The function works under the assumption that we move in the input stream +-- only forwards and never backwards, which is always true unless the user +-- abuses the library. +-- +-- @since 7.0.0 +getSourcePos :: (TraversableStream s, MonadParsec e s m) => m SourcePos +getSourcePos = do + st <- getParserState + let pst = reachOffsetNoLine (stateOffset st) (statePosState st) + setParserState st {statePosState = pst} + return (pstateSourcePos pst) +{-# INLINE getSourcePos #-} --- | Extract a given number of tokens from the stream. +-- | Get the number of tokens processed so far. +-- +-- See also: 'setOffset'. +-- +-- @since 7.0.0 +getOffset :: (MonadParsec e s m) => m Int +getOffset = stateOffset <$> getParserState +{-# INLINE getOffset #-} -streamTake :: forall s. Stream s => Int -> s -> [Token s] -streamTake n s = - case fst <$> takeN_ n s of - Nothing -> [] - Just chunk -> chunkToTokens (Proxy :: Proxy s) chunk +-- | Set the number of tokens processed so far. +-- +-- See also: 'getOffset'. +-- +-- @since 7.0.0 +setOffset :: (MonadParsec e s m) => Int -> m () +setOffset o = updateParserState $ \(State s _ pst de) -> + State s o pst de +{-# INLINE setOffset #-} + +-- | @'setParserState' st@ sets the parser state to @st@. +-- +-- See also: 'getParserState', 'updateParserState'. +setParserState :: (MonadParsec e s m) => State s e -> m () +setParserState st = updateParserState (const st) +{-# INLINE setParserState #-} diff --git a/Text/Megaparsec/Byte.hs b/Text/Megaparsec/Byte.hs --- a/Text/Megaparsec/Byte.hs +++ b/Text/Megaparsec/Byte.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Byte --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -10,179 +15,190 @@ -- Commonly used binary parsers. -- -- @since 6.0.0 - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Byte ( -- * Simple parsers - newline - , crlf - , eol - , tab - , space - , space1 + newline, + crlf, + eol, + tab, + space, + hspace, + space1, + hspace1, + -- * Categories of characters - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , octDigitChar - , hexDigitChar - , asciiChar - -- * More general parsers - , C.char - , char' - , C.anyChar - , C.notChar - , C.oneOf - , C.noneOf - , C.satisfy + controlChar, + spaceChar, + upperChar, + lowerChar, + letterChar, + alphaNumChar, + printChar, + digitChar, + binDigitChar, + octDigitChar, + hexDigitChar, + asciiChar, + + -- * Single byte + char, + char', + -- * Sequence of bytes - , C.string - , C.string' ) + string, + string', + ) where import Control.Applicative -import Data.Char +import Data.Char hiding (isSpace, toLower, toUpper) import Data.Functor (void) -import Data.Maybe (fromMaybe) import Data.Proxy import Data.Word (Word8) import Text.Megaparsec -import qualified Text.Megaparsec.Char as C +import Text.Megaparsec.Common ---------------------------------------------------------------------------- -- Simple parsers -- | Parse a newline byte. - newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -newline = C.char 10 +newline = char 10 {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. - crlf :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s) -crlf = C.string (tokensToChunk (Proxy :: Proxy s) [13,10]) +crlf = string (tokensToChunk (Proxy :: Proxy s) [13, 10]) {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. - eol :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s) -eol = (tokenToChunk (Proxy :: Proxy s) <$> newline) - <|> crlf - "end of line" +eol = + (tokenToChunk (Proxy :: Proxy s) <$> newline) + <|> crlf + "end of line" {-# INLINE eol #-} -- | Parse a tab character. - tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -tab = C.char 9 +tab = char 9 {-# INLINE tab #-} -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. - space :: (MonadParsec e s m, Token s ~ Word8) => m () -space = void $ takeWhileP (Just "white space") isSpace' +space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace :: (MonadParsec e s m, Token s ~ Word8) => m () +hspace = void $ takeWhileP (Just "white space") isHSpace +{-# INLINE hspace #-} + -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'. - space1 :: (MonadParsec e s m, Token s ~ Word8) => m () -space1 = void $ takeWhile1P (Just "white space") isSpace' +space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace1 :: (MonadParsec e s m, Token s ~ Word8) => m () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace +{-# INLINE hspace1 #-} + ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character. - controlChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -controlChar = C.satisfy (isControl . toChar) "control character" +controlChar = satisfy (isControl . toChar) "control character" {-# INLINE controlChar #-} -- | Parse a space character, and the control characters: tab, newline, -- carriage return, form feed, and vertical tab. - spaceChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -spaceChar = C.satisfy isSpace' "white space" +spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} -- | Parse an upper-case character. - upperChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -upperChar = C.satisfy (isUpper . toChar) "uppercase letter" +upperChar = satisfy (isUpper . toChar) "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic character. - lowerChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -lowerChar = C.satisfy (isLower . toChar) "lowercase letter" +lowerChar = satisfy (isLower . toChar) "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic character: lower-case or upper-case. - letterChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -letterChar = C.satisfy (isLetter . toChar) "letter" +letterChar = satisfy (isLetter . toChar) "letter" {-# INLINE letterChar #-} -- | Parse an alphabetic or digit characters. - alphaNumChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -alphaNumChar = C.satisfy (isAlphaNum . toChar) "alphanumeric character" +alphaNumChar = satisfy (isAlphaNum . toChar) "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable character: letter, number, mark, punctuation, symbol -- or space. - printChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -printChar = C.satisfy (isPrint . toChar) "printable character" +printChar = satisfy (isPrint . toChar) "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. - digitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -digitChar = C.satisfy isDigit' "digit" +digitChar = satisfy isDigit' "digit" where isDigit' x = x >= 48 && x <= 57 {-# INLINE digitChar #-} --- | Parse an octal digit, i.e. between “0” and “7”. +-- | Parse a binary digit, i.e. “0” or “1”. +-- +-- @since 7.0.0 +binDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) +binDigitChar = satisfy isBinDigit "binary digit" + where + isBinDigit x = x == 48 || x == 49 +{-# INLINE binDigitChar #-} +-- | Parse an octal digit, i.e. between “0” and “7”. octDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -octDigitChar = C.satisfy isOctDigit' "octal digit" +octDigitChar = satisfy isOctDigit' "octal digit" where isOctDigit' x = x >= 48 && x <= 55 {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. - hexDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -hexDigitChar = C.satisfy (isHexDigit . toChar) "hexadecimal digit" +hexDigitChar = satisfy (isHexDigit . toChar) "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. - asciiChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -asciiChar = C.satisfy (< 128) "ASCII character" +asciiChar = satisfy (< 128) "ASCII character" {-# INLINE asciiChar #-} ---------------------------------------------------------------------------- --- More general parsers +-- Single byte +-- | A type-constrained version of 'single'. +-- +-- > newline = char 10 +char :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) +char = single +{-# INLINE char #-} + -- | The same as 'char' but case-insensitive. This parser returns the -- actually parsed character preserving its case. -- @@ -192,44 +208,57 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' - char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) -char' c = choice - [ C.char c - , C.char (fromMaybe c (swapCase c)) ] - where - swapCase x - | isUpper g = fromChar (toLower g) - | isLower g = fromChar (toUpper g) - | otherwise = Nothing - where - g = toChar x +char' c = + choice + [ char (toLower c), + char (toUpper c) + ] {-# INLINE char' #-} ---------------------------------------------------------------------------- -- Helpers --- | 'Word8'-specialized version of 'isSpace'. - -isSpace' :: Word8 -> Bool -isSpace' x +-- | 'Word8'-specialized version of 'Data.Char.isSpace'. +isSpace :: Word8 -> Bool +isSpace x | x >= 9 && x <= 13 = True - | x == 32 = True - | x == 160 = True - | otherwise = False -{-# INLINE isSpace' #-} + | x == 32 = True + | x == 160 = True + | otherwise = False +{-# INLINE isSpace #-} --- | Convert a byte to char. +-- | Like 'isSpace', but does not accept newlines and carriage returns. +isHSpace :: Word8 -> Bool +isHSpace x + | x == 9 = True + | x == 11 = True + | x == 12 = True + | x == 32 = True + | x == 160 = True + | otherwise = False +{-# INLINE isHSpace #-} +-- | Convert a byte to char. toChar :: Word8 -> Char toChar = chr . fromIntegral {-# INLINE toChar #-} --- | Convert a char to byte. +-- | Convert a byte to its upper-case version. +toUpper :: Word8 -> Word8 +toUpper x + | x >= 97 && x <= 122 = x - 32 + | x == 247 = x -- division sign + | x == 255 = x -- latin small letter y with diaeresis + | x >= 224 = x - 32 + | otherwise = x +{-# INLINE toUpper #-} -fromChar :: Char -> Maybe Word8 -fromChar x = let p = ord x in - if p > 0xff - then Nothing - else Just (fromIntegral p) -{-# INLINE fromChar #-} +-- | Convert a byte to its lower-case version. +toLower :: Word8 -> Word8 +toLower x + | x >= 65 && x <= 90 = x + 32 + | x == 215 = x -- multiplication sign + | x >= 192 && x <= 222 = x + 32 + | otherwise = x +{-# INLINE toLower #-} 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 --- a/Text/Megaparsec/Byte/Lexer.hs +++ b/Text/Megaparsec/Byte/Lexer.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Byte.Lexer --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -13,108 +18,139 @@ -- This module is intended to be imported qualified: -- -- > import qualified Text.Megaparsec.Byte.Lexer as L - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Byte.Lexer ( -- * White space - C.space - , C.lexeme - , C.symbol - , C.symbol' - , skipLineComment - , skipBlockComment - , skipBlockCommentNested + space, + lexeme, + symbol, + symbol', + skipLineComment, + skipBlockComment, + skipBlockCommentNested, + -- * Numbers - , decimal - , octal - , hexadecimal - , scientific - , float - , signed ) + decimal, + binary, + octal, + hexadecimal, + scientific, + float, + signed, + ) where import Control.Applicative import Data.Functor (void) -import Data.List (foldl') +import qualified Data.List import Data.Proxy import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci import Data.Word (Word8) import Text.Megaparsec -import Text.Megaparsec.Byte -import qualified Data.Scientific as Sci -import qualified Text.Megaparsec.Char.Lexer as C +import qualified Text.Megaparsec.Byte as B +import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space --- | Given comment prefix this function returns a parser that skips line +-- | Given a comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually. - -skipLineComment :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Line comment prefix - -> m () +skipLineComment :: + (MonadParsec e s m, Token s ~ Word8) => + -- | Line comment prefix + Tokens s -> + m () skipLineComment prefix = - string prefix *> void (takeWhileP (Just "character") (/= 10)) + B.string prefix *> void (takeWhileP (Just "character") (/= 10)) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. - -skipBlockComment :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () -skipBlockComment start end = p >> void (manyTill anyChar n) +skipBlockComment :: + (MonadParsec e s m) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () +skipBlockComment start end = p >> void (manyTill anySingle n) where - p = string start - n = string end + p = B.string start + n = B.string end {-# INLINEABLE skipBlockComment #-} -- | @'skipBlockCommentNested' start end@ skips possibly nested block -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0 - -skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockCommentNested :: + (MonadParsec e s m, Token s ~ Word8) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockCommentNested start end = p >> void (manyTill e n) where - e = skipBlockCommentNested start end <|> void anyChar - p = string start - n = string end + e = skipBlockCommentNested start end <|> void anySingle + p = B.string start + n = B.string end {-# INLINEABLE skipBlockCommentNested #-} ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of --- integer literals described in the Haskell report. +-- | Parse an integer in the decimal representation according to the format +-- of integer literals described in the Haskell report. -- --- If you need to parse signed integers, see 'signed' combinator. - -decimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a) - => m a +-- If you need to parse signed integers, see the 'signed' combinator. +-- +-- __Warning__: this function does not perform range checks. +decimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a decimal = decimal_ "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers. - -decimal_ - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a) - => m a +decimal_ :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a decimal_ = mkNum <$> takeWhile1P (Just "digit") isDigit where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w = a * 10 + fromIntegral (w - 48) +{-# INLINE decimal_ #-} --- | Parse an integer in octal representation. Representation of octal +-- | Parse an integer in the binary representation. The binary number is +-- expected to be a non-empty sequence of zeroes “0” and ones “1”. +-- +-- You could of course parse some prefix before the actual number: +-- +-- > binary = char 48 >> char' 98 >> L.binary +-- +-- __Warning__: this function does not perform range checks. +-- +-- @since 7.0.0 +binary :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +binary = + mkNum + <$> takeWhile1P Nothing isBinDigit + "binary integer" + where + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a w = a * 2 + fromIntegral (w - 48) + isBinDigit w = w == 48 || w == 49 +{-# INLINEABLE binary #-} + +-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing @@ -122,21 +158,24 @@ -- -- For example you can make it conform to the Haskell report like this: -- --- > octal = char '0' >> char' 'o' >> L.octal - -octal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a) - => m a -octal = mkNum - <$> takeWhile1P Nothing isOctDigit - "octal integer" +-- > octal = char 48 >> char' 111 >> L.octal +-- +-- __Warning__: this function does not perform range checks. +octal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +octal = + mkNum + <$> takeWhile1P Nothing isOctDigit + "octal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) - step a w = a * 8 + fromIntegral (w - 48) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a w = a * 8 + fromIntegral (w - 48) isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of +-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before @@ -144,24 +183,27 @@ -- -- For example you can make it conform to the Haskell report like this: -- --- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal - -hexadecimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a) - => m a -hexadecimal = mkNum - <$> takeWhile1P Nothing isHexDigit - "hexadecimal integer" +-- > hexadecimal = char 48 >> char' 120 >> L.hexadecimal +-- +-- __Warning__: this function does not perform range checks. +hexadecimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +hexadecimal = + mkNum + <$> takeWhile1P Nothing isHexDigit + "hexadecimal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48) - | w >= 97 = a * 16 + fromIntegral (w - 87) - | otherwise = a * 16 + fromIntegral (w - 55) + | w >= 97 = a * 16 + fromIntegral (w - 87) + | otherwise = a * 16 + fromIntegral (w - 55) isHexDigit w = - (w >= 48 && w <= 57) || - (w >= 97 && w <= 102) || - (w >= 65 && w <= 70) + (w >= 48 && w <= 57) + || (w >= 97 && w <= 102) + || (w >= 65 && w <= 70) {-# INLINEABLE hexadecimal #-} -- | Parse a floating point value as a 'Scientific' number. 'Scientific' is @@ -174,14 +216,14 @@ -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. - -scientific - :: forall e s m. (MonadParsec e s m, Token s ~ Word8) - => m Scientific +scientific :: + forall e s m. + (MonadParsec e s m, Token s ~ Word8) => + m Scientific scientific = do - c' <- decimal_ + c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c') - e <- option e' (try $ exponent_ e') + e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -193,36 +235,41 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- --- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers. - +-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain integers. float :: (MonadParsec e s m, Token s ~ Word8, RealFloat a) => m a float = do c' <- decimal_ - Sci.toRealFloat <$> - ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' - e <- option e' (try $ exponent_ e') - return (Sci.scientific c e)) - <|> (Sci.scientific c' <$> exponent_ 0)) + Sci.toRealFloat + <$> ( ( do + SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' + e <- option e' (try $ exponent_ e') + return (Sci.scientific c e) + ) + <|> (Sci.scientific c' <$> exponent_ 0) + ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Word8) - => Proxy s - -> Integer - -> m SP +dotDecimal_ :: + (MonadParsec e s m, Token s ~ Word8) => + Proxy s -> + Integer -> + m SP dotDecimal_ pxy c' = do - void (char 46) - let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy - step (SP a e') w = SP - (a * 10 + fromIntegral (w - 48)) - (e' - 1) + void (B.char 46) + let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy + step (SP a e') w = + SP + (a * 10 + fromIntegral (w - 48)) + (e' - 1) mkNum <$> takeWhile1P (Just "digit") isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Word8) - => Int - -> m Int +exponent_ :: + (MonadParsec e s m, Token s ~ Word8) => + Int -> + m Int exponent_ e' = do - void (char' 101) + void (B.char' 101) (+ e') <$> signed (return ()) decimal_ {-# INLINE exponent_ #-} @@ -237,21 +284,23 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer - -signed :: (MonadParsec e s m, Token s ~ Word8, Num a) - => m () -- ^ How to consume white space after the sign - -> m a -- ^ How to parse the number itself - -> m a -- ^ Parser for signed numbers -signed spc p = ($) <$> option id (C.lexeme spc sign) <*> p +signed :: + (MonadParsec e s m, Token s ~ Word8, Num a) => + -- | How to consume white space after the sign + m () -> + -- | How to parse the number itself + m a -> + -- | Parser for signed numbers + m a +signed spc p = option id (lexeme spc sign) <*> p where - sign = (id <$ char 43) <|> (negate <$ char 45) + sign = (id <$ B.char 43) <|> (negate <$ B.char 45) {-# INLINEABLE signed #-} ---------------------------------------------------------------------------- -- Helpers --- | A fast predicate to check if given 'Word8' is a digit in ASCII. - +-- | A fast predicate to check if the given 'Word8' is a digit in ASCII. isDigit :: Word8 -> Bool isDigit w = w - 48 < 10 {-# INLINE isDigit #-} 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–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -10,96 +17,80 @@ -- Portability : non-portable -- -- Commonly used character parsers. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Char ( -- * Simple parsers - newline - , crlf - , eol - , tab - , space - , space1 + newline, + crlf, + eol, + tab, + space, + hspace, + space1, + hspace1, + -- * Categories of characters - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , octDigitChar - , hexDigitChar - , markChar - , numberChar - , punctuationChar - , symbolChar - , separatorChar - , asciiChar - , latin1Char - , charCategory - , categoryName - -- * More general parsers - , char - , char' - , anyChar - , notChar - , oneOf - , noneOf - , satisfy + controlChar, + spaceChar, + upperChar, + lowerChar, + letterChar, + alphaNumChar, + printChar, + digitChar, + binDigitChar, + octDigitChar, + hexDigitChar, + markChar, + numberChar, + punctuationChar, + symbolChar, + separatorChar, + asciiChar, + latin1Char, + charCategory, + categoryName, + + -- * Single character + char, + char', + -- * Sequence of characters - , string - , string' ) + string, + string', + ) where import Control.Applicative import Data.Char -import Data.Function (on) import Data.Functor (void) -import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Text.Megaparsec -import qualified Data.CaseInsensitive as CI -import qualified Data.Set as E - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable (), elem, notElem) -import Prelude hiding (elem, notElem) -#endif +import Text.Megaparsec.Common ---------------------------------------------------------------------------- -- Simple parsers -- | Parse a newline character. - newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. - crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. - eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) -eol = (tokenToChunk (Proxy :: Proxy s) <$> newline) - <|> crlf - "end of line" +eol = + (tokenToChunk (Proxy :: Proxy s) <$> newline) + <|> crlf + "end of line" {-# INLINE eol #-} -- | Parse a tab character. - tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-} @@ -107,34 +98,44 @@ -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. - space :: (MonadParsec e s m, Token s ~ Char) => m () space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace :: (MonadParsec e s m, Token s ~ Char) => m () +hspace = void $ takeWhileP (Just "white space") isHSpace +{-# INLINE hspace #-} + -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'. -- -- @since 6.0.0 - space1 :: (MonadParsec e s m, Token s ~ Char) => m () space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace1 :: (MonadParsec e s m, Token s ~ Char) => m () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace +{-# INLINE hspace1 #-} + ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode). - controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl "control character" {-# INLINE controlChar #-} -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. - spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} @@ -142,20 +143,17 @@ -- | Parse an upper-case or title-case alphabetic Unicode character. Title -- case is used by a small number of letter ligatures like the -- single-character form of Lj. - upperChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) upperChar = satisfy isUpper "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic Unicode character. - lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter. - letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter "letter" {-# INLINE letterChar #-} @@ -165,144 +163,133 @@ -- Note that the numeric digits outside the ASCII range are parsed by this -- parser but not by 'digitChar'. Such digits may be part of identifiers but -- are not used by the printer and reader to represent numbers. - alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) alphaNumChar = satisfy isAlphaNum "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space. - printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. - digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit "digit" {-# INLINE digitChar #-} --- | Parse an octal digit, i.e. between “0” and “7”. +-- | Parse a binary digit, i.e. "0" or "1". +-- +-- @since 7.0.0 +binDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) +binDigitChar = satisfy isBinDigit "binary digit" + where + isBinDigit x = x == '0' || x == '1' +{-# INLINE binDigitChar #-} +-- | Parse an octal digit, i.e. between “0” and “7”. octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) octDigitChar = satisfy isOctDigit "octal digit" {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. - hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters. - markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark "mark character" {-# INLINE markChar #-} -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc. - numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber "numeric character" {-# INLINE numberChar #-} -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes. - punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) punctuationChar = satisfy isPunctuation "punctuation" {-# INLINE punctuationChar #-} -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols. - symbolChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) symbolChar = satisfy isSymbol "symbol" {-# INLINE symbolChar #-} -- | Parse a Unicode space and separator characters. - separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator "separator" {-# INLINE separatorChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. - asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii "ASCII character" {-# INLINE asciiChar #-} -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. - latin1Char :: (MonadParsec e s m, Token s ~ Char) => m (Token s) latin1Char = satisfy isLatin1 "Latin-1 character" {-# INLINE latin1Char #-} -- | @'charCategory' cat@ parses character in Unicode General Category -- @cat@, see 'Data.Char.GeneralCategory'. - -charCategory :: (MonadParsec e s m, Token s ~ Char) - => GeneralCategory - -> m (Token s) +charCategory :: + (MonadParsec e s m, Token s ~ Char) => + GeneralCategory -> + m (Token s) charCategory cat = satisfy ((== cat) . generalCategory) categoryName cat {-# INLINE charCategory #-} -- | Return the human-readable name of Unicode General Category. - categoryName :: GeneralCategory -> String categoryName = \case - UppercaseLetter -> "uppercase letter" - LowercaseLetter -> "lowercase letter" - TitlecaseLetter -> "titlecase letter" - ModifierLetter -> "modifier letter" - OtherLetter -> "other letter" - NonSpacingMark -> "non-spacing mark" + UppercaseLetter -> "uppercase letter" + LowercaseLetter -> "lowercase letter" + TitlecaseLetter -> "titlecase letter" + ModifierLetter -> "modifier letter" + OtherLetter -> "other letter" + NonSpacingMark -> "non-spacing mark" SpacingCombiningMark -> "spacing combining mark" - EnclosingMark -> "enclosing mark" - DecimalNumber -> "decimal number character" - LetterNumber -> "letter number character" - OtherNumber -> "other number character" + EnclosingMark -> "enclosing mark" + DecimalNumber -> "decimal number character" + LetterNumber -> "letter number character" + OtherNumber -> "other number character" ConnectorPunctuation -> "connector punctuation" - DashPunctuation -> "dash punctuation" - OpenPunctuation -> "open punctuation" - ClosePunctuation -> "close punctuation" - InitialQuote -> "initial quote" - FinalQuote -> "final quote" - OtherPunctuation -> "other punctuation" - MathSymbol -> "math symbol" - CurrencySymbol -> "currency symbol" - ModifierSymbol -> "modifier symbol" - OtherSymbol -> "other symbol" - Space -> "white space" - LineSeparator -> "line separator" - ParagraphSeparator -> "paragraph separator" - Control -> "control character" - Format -> "format character" - Surrogate -> "surrogate character" - PrivateUse -> "private-use Unicode character" - NotAssigned -> "non-assigned Unicode character" + DashPunctuation -> "dash punctuation" + OpenPunctuation -> "open punctuation" + ClosePunctuation -> "close punctuation" + InitialQuote -> "initial quote" + FinalQuote -> "final quote" + OtherPunctuation -> "other punctuation" + MathSymbol -> "math symbol" + CurrencySymbol -> "currency symbol" + ModifierSymbol -> "modifier symbol" + OtherSymbol -> "other symbol" + Space -> "white space" + LineSeparator -> "line separator" + ParagraphSeparator -> "paragraph separator" + Control -> "control character" + Format -> "format character" + Surrogate -> "surrogate character" + PrivateUse -> "private-use Unicode character" + NotAssigned -> "non-assigned Unicode character" ---------------------------------------------------------------------------- --- More general parsers +-- Single character --- | @'char' c@ parses a single character @c@. +-- | A type-constrained version of 'single'. -- -- > semicolon = char ';' - -char :: MonadParsec e s m => Token s -> m (Token s) -char c = token testChar (Just c) - where - f x = Tokens (x:|[]) - testChar x = - if x == c - then Right x - else Left (pure (f x), E.singleton (f c)) +char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) +char = single {-# INLINE char #-} -- | The same as 'char' but case-insensitive. This parser returns the @@ -314,110 +301,18 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' - char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) -char' c = choice [char c, char (swapCase c)] - where - swapCase x - | isUpper x = toLower x - | isLower x = toUpper x - | otherwise = x +char' c = + choice + [ char (toLower c), + char (toUpper c), + char (toTitle c) + ] {-# INLINE char' #-} --- | This parser succeeds for any character. Returns the parsed character. - -anyChar :: MonadParsec e s m => m (Token s) -anyChar = satisfy (const True) "character" -{-# INLINE anyChar #-} - --- | Match any character but the given one. It's a good idea to attach a --- 'label' to this parser manually. --- --- @since 6.0.0 - -notChar :: MonadParsec e s m => Token s -> m (Token s) -notChar c = satisfy (/= c) -{-# INLINE notChar #-} - --- | @'oneOf' cs@ succeeds if the current character is in the supplied --- collection of characters @cs@. Returns the parsed character. Note that --- this parser cannot automatically generate the “expected” component of --- error message, so usually you should label it manually with 'label' or --- (''). --- --- See also: 'satisfy'. --- --- > digit = oneOf ['0'..'9'] "digit" --- --- __Performance note__: prefer 'satisfy' when you can because it's faster --- when you have only a couple of tokens to compare to: --- --- > quoteFast = satisfy (\x -> x == '\'' || x == '\"') --- > quoteSlow = oneOf "'\"" - -oneOf :: (Foldable f, MonadParsec e s m) - => f (Token s) - -> m (Token s) -oneOf cs = satisfy (`elem` cs) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @'noneOf' cs@ succeeds if the current character --- /not/ in the supplied list of characters @cs@. Returns the parsed --- character. Note that this parser cannot automatically generate the --- “expected” component of error message, so usually you should label it --- manually with 'label' or (''). --- --- See also: 'satisfy'. --- --- __Performance note__: prefer 'satisfy' and 'notChar' when you can because --- it's faster. - -noneOf :: (Foldable f, MonadParsec e s m) - => f (Token s) - -> m (Token s) -noneOf cs = satisfy (`notElem` cs) -{-# INLINE noneOf #-} - --- | The parser @'satisfy' f@ succeeds for any character for which the --- supplied function @f@ returns 'True'. Returns the character that is --- actually parsed. --- --- > digitChar = satisfy isDigit "digit" --- > oneOf cs = satisfy (`elem` cs) - -satisfy :: MonadParsec e s m - => (Token s -> Bool) -- ^ Predicate to apply - -> m (Token s) -satisfy f = token testChar Nothing - where - testChar x = - if f x - then Right x - else Left (pure (Tokens (x:|[])), E.empty) -{-# INLINE satisfy #-} - ---------------------------------------------------------------------------- --- Sequence of characters - --- | @'string' s@ parses a sequence of characters given by @s@. Returns the --- parsed string (i.e. @s@). --- --- > divOrMod = string "div" <|> string "mod" - -string :: MonadParsec e s m - => Tokens s - -> m (Tokens s) -string = tokens (==) -{-# INLINE string #-} - --- | The same as 'string', but case-insensitive. On success returns string --- cased as actually parsed input. --- --- >>> parseTest (string' "foobar") "foObAr" --- "foObAr" +-- Helpers -string' :: (MonadParsec e s m, CI.FoldCase (Tokens s)) - => Tokens s - -> m (Tokens s) -string' = tokens ((==) `on` CI.mk) -{-# INLINE string' #-} +-- | Is it a horizontal space character? +isHSpace :: Char -> Bool +isHSpace x = isSpace x && x /= '\n' && x /= '\r' diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs --- a/Text/Megaparsec/Char/Lexer.hs +++ b/Text/Megaparsec/Char/Lexer.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Char.Lexer --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -11,8 +18,7 @@ -- -- High-level parsers to help you write your lexer. The module doesn't -- impose how you should write your parser, but certain approaches may be --- more elegant than others. Especially important theme is parsing of white --- space, comments, and indentation. +-- more elegant than others. -- -- Parsing of white space is an important part of any parser. We propose a -- convention where __every lexeme parser assumes no spaces before the__ @@ -27,159 +33,79 @@ -- > import qualified Text.Megaparsec.Char.Lexer as L -- -- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer". - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Char.Lexer ( -- * White space - space - , lexeme - , symbol - , symbol' - , skipLineComment - , skipBlockComment - , skipBlockCommentNested + space, + lexeme, + symbol, + symbol', + skipLineComment, + skipBlockComment, + skipBlockCommentNested, + -- * Indentation - , indentLevel - , incorrectIndent - , indentGuard - , nonIndented - , IndentOpt (..) - , indentBlock - , lineFold + indentLevel, + incorrectIndent, + indentGuard, + nonIndented, + IndentOpt (..), + indentBlock, + lineFold, + -- * Character and string literals - , charLiteral + charLiteral, + -- * Numbers - , decimal - , octal - , hexadecimal - , scientific - , float - , signed ) + decimal, + binary, + octal, + hexadecimal, + scientific, + float, + signed, + ) where import Control.Applicative import Control.Monad (void) -import Data.List (foldl') +import qualified Data.Char as Char +import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (listToMaybe, fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci +import qualified Data.Set as E import Text.Megaparsec -import qualified Data.CaseInsensitive as CI -import qualified Data.Char as Char -import qualified Data.Scientific as Sci -import qualified Data.Set as E import qualified Text.Megaparsec.Char as C +import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space --- | @'space' sc lineComment blockComment@ produces parser that can parse --- white space in general. It's expected that you create such a parser once --- and pass it to other functions in this module as needed (when you see --- @spaceConsumer@ in documentation, usually it means that something like --- 'space' is expected there). --- --- @sc@ is used to parse blocks of space characters. You can use 'C.space1' --- from "Text.Megaparsec.Char" for this purpose as well as your own parser --- (if you don't want to automatically consume newlines, for example). Make --- sure the parser does not succeed on empty input though. In earlier --- version 'C.spaceChar' was recommended, but now parsers based on --- 'takeWhile1P' are preferred because of their speed. --- --- @lineComment@ is used to parse line comments. You can use --- 'skipLineComment' if you don't need anything special. --- --- @blockComment@ is used to parse block (multi-line) comments. You can use --- 'skipBlockComment' or 'skipBlockCommentNested' if you don't need anything --- special. --- --- If you don't want to allow a kind of comment, simply pass 'empty' which --- will fail instantly when parsing of that sort of comment is attempted and --- 'space' will just move on or finish depending on whether there is more --- white space for it to consume. - -space :: MonadParsec e s m - => m () -- ^ A parser for space characters which does not accept empty - -- input (e.g. 'C.space1') - -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') - -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') - -> m () -space sp line block = skipMany $ choice - [hidden sp, hidden line, hidden block] -{-# INLINEABLE space #-} - --- | This is a wrapper for lexemes. Typical usage is to supply the first --- argument (parser that consumes white space, probably defined via 'space') --- and use the resulting function to wrap parsers for every lexeme. --- --- > lexeme = L.lexeme spaceConsumer --- > integer = lexeme L.decimal - -lexeme :: MonadParsec e s m - => m () -- ^ How to consume white space after lexeme - -> m a -- ^ How to parse actual lexeme - -> m a -lexeme spc p = p <* spc -{-# INLINEABLE lexeme #-} - --- | This is a helper to parse symbols, i.e. verbatim strings. You pass the --- first argument (parser that consumes white space, probably defined via --- 'space') and then you can use the resulting function to parse strings: --- --- > symbol = L.symbol spaceConsumer --- > --- > parens = between (symbol "(") (symbol ")") --- > braces = between (symbol "{") (symbol "}") --- > angles = between (symbol "<") (symbol ">") --- > brackets = between (symbol "[") (symbol "]") --- > semicolon = symbol ";" --- > comma = symbol "," --- > colon = symbol ":" --- > dot = symbol "." - -symbol :: MonadParsec e s m - => m () -- ^ How to consume white space after lexeme - -> Tokens s -- ^ Symbol to parse - -> m (Tokens s) -symbol spc = lexeme spc . C.string -{-# INLINEABLE symbol #-} - --- | Case-insensitive version of 'symbol'. This may be helpful if you're --- working with case-insensitive languages. - -symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s)) - => m () -- ^ How to consume white space after lexeme - -> Tokens s -- ^ Symbol to parse (case-insensitive) - -> m (Tokens s) -symbol' spc = lexeme spc . C.string' -{-# INLINEABLE symbol' #-} - --- | Given comment prefix this function returns a parser that skips line +-- | Given a comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually. - -skipLineComment :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Line comment prefix - -> m () +skipLineComment :: + (MonadParsec e s m, Token s ~ Char) => + -- | Line comment prefix + Tokens s -> + m () skipLineComment prefix = C.string prefix *> void (takeWhileP (Just "character") (/= '\n')) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. - -skipBlockComment :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () -skipBlockComment start end = p >> void (manyTill C.anyChar n) +skipBlockComment :: + (MonadParsec e s m) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () +skipBlockComment start end = p >> void (manyTill anySingle n) where p = C.string start n = C.string end @@ -189,14 +115,16 @@ -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0 - -skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockCommentNested :: + (MonadParsec e s m, Token s ~ Char) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockCommentNested start end = p >> void (manyTill e n) where - e = skipBlockCommentNested start end <|> void C.anyChar + e = skipBlockCommentNested start end <|> void anySingle p = C.string start n = C.string end {-# INLINEABLE skipBlockCommentNested #-} @@ -211,10 +139,9 @@ -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0 - -indentLevel :: MonadParsec e s m => m Pos -indentLevel = sourceColumn <$> getPosition -{-# INLINEABLE indentLevel #-} +indentLevel :: (TraversableStream s, MonadParsec e s m) => m Pos +indentLevel = sourceColumn <$> getSourcePos +{-# INLINE indentLevel #-} -- | Fail reporting incorrect indentation error. The error has attached -- information: @@ -224,14 +151,18 @@ -- * Actual indentation level -- -- @since 5.0.0 - -incorrectIndent :: MonadParsec e s m - => Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> Pos -- ^ Actual indentation level - -> m a -incorrectIndent ord ref actual = fancyFailure . E.singleton $ - ErrorIndentation ord ref actual +incorrectIndent :: + (MonadParsec e s m) => + -- | Desired ordering between reference level and actual level + Ordering -> + -- | Reference indentation level + Pos -> + -- | Actual indentation level + Pos -> + m a +incorrectIndent ord ref actual = + fancyFailure . E.singleton $ + ErrorIndentation ord ref actual {-# INLINEABLE incorrectIndent #-} -- | @'indentGuard' spaceConsumer ord ref@ first consumes all white space @@ -244,12 +175,16 @@ -- arguments like @'indentGuard' spaceConsumer 'GT' 'pos1'@—this will make -- sure you have some indentation. Use returned value to check indentation -- on every subsequent line according to syntax of your language. - -indentGuard :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> m Pos -- ^ Current column (indentation level) +indentGuard :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | Desired ordering between reference level and actual level + Ordering -> + -- | Reference indentation level + Pos -> + -- | Current column (indentation level) + m Pos indentGuard sc ord ref = do sc actual <- indentLevel @@ -263,52 +198,54 @@ -- top-level function definitions. -- -- @since 4.3.0 - -nonIndented :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> m a -- ^ How to parse actual data - -> m a +nonIndented :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | How to parse actual data + m a -> + m a nonIndented sc p = indentGuard sc EQ pos1 *> p {-# INLINEABLE nonIndented #-} --- | The data type represents available behaviors for parsing of indented --- tokens. This is used in 'indentBlock', which see. +-- | Behaviors for parsing of indented tokens. This is used in +-- 'indentBlock', which see. -- -- @since 4.3.0 - data IndentOpt m a b - = IndentNone a - -- ^ Parse no indented tokens, just return the value - | IndentMany (Maybe Pos) ([b] -> m a) (m b) - -- ^ Parse many indented tokens (possibly zero), use given indentation + = -- | Parse no indented tokens, just return the value + IndentNone a + | -- | Parse many indented tokens (possibly zero), use given indentation -- level (if 'Nothing', use level of the first indented token); the -- second argument tells how to get the final result, and the third -- argument describes how to parse an indented token - | IndentSome (Maybe Pos) ([b] -> m a) (m b) - -- ^ Just like 'IndentMany', but requires at least one indented token to + IndentMany (Maybe Pos) ([b] -> m a) (m b) + | -- | Just like 'IndentMany', but requires at least one indented token to -- be present + IndentSome (Maybe Pos) ([b] -> m a) (m b) --- | Parse a “reference” token and a number of other tokens that have --- greater (but the same) level of indentation than that of “reference” --- token. Reference token can influence parsing, see 'IndentOpt' for more --- information. +-- | Parse a “reference” token and a number of other tokens that have a +-- greater (but the same for all of them) level of indentation than that of +-- the “reference” token. The reference token can influence parsing, see +-- 'IndentOpt' for more information. -- --- Tokens /must not/ consume newlines after them. On the other hand, the --- first argument of this function /must/ consume newlines among other white --- space characters. +-- __Note__: the first argument of this function /must/ consume newlines +-- among other white space characters. -- -- @since 4.3.0 - -indentBlock :: (MonadParsec e s m, Token s ~ Char) - => m () -- ^ How to consume indentation (white space) - -> m (IndentOpt m a b) -- ^ How to parse “reference” token - -> m a +indentBlock :: + (TraversableStream s, MonadParsec e s m, Token s ~ Char) => + -- | How to consume indentation (white space) + m () -> + -- | How to parse “reference” token + m (IndentOpt m a b) -> + m a indentBlock sc r = do sc ref <- indentLevel - a <- r + a <- r case a of - IndentNone x -> sc *> return x + IndentNone x -> x <$ sc IndentMany indent f p -> do mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref) done <- isJust <$> optional eof @@ -319,40 +256,48 @@ IndentSome indent f p -> do pos <- C.eol *> indentGuard sc GT ref let lvl = fromMaybe pos indent - x <- if | pos <= ref -> incorrectIndent GT ref pos - | pos == lvl -> p - | otherwise -> incorrectIndent EQ lvl pos - xs <- indentedItems ref lvl sc p - f (x:xs) + x <- + if + | pos <= ref -> incorrectIndent GT ref pos + | pos == lvl -> p + | otherwise -> incorrectIndent EQ lvl pos + xs <- indentedItems ref lvl sc p + f (x : xs) {-# INLINEABLE indentBlock #-} -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of the public API. - -indentedItems :: MonadParsec e s m - => Pos -- ^ Reference indentation level - -> Pos -- ^ Level of the first indented item ('lookAhead'ed) - -> m () -- ^ How to consume indentation (white space) - -> m b -- ^ How to parse indented tokens - -> m [b] +indentedItems :: + (TraversableStream s, MonadParsec e s m) => + -- | Reference indentation level + Pos -> + -- | Level of the first indented item ('lookAhead'ed) + Pos -> + -- | How to consume indentation (white space) + m () -> + -- | How to parse indented tokens + m b -> + m [b] indentedItems ref lvl sc p = go where go = do sc - pos <- indentLevel + pos <- indentLevel done <- isJust <$> optional eof if done then return [] - else if | pos <= ref -> return [] - | pos == lvl -> (:) <$> p <*> go - | otherwise -> incorrectIndent EQ lvl pos + else + if + | pos <= ref -> return [] + | pos == lvl -> (:) <$> p <*> go + | otherwise -> incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/ -- consume newlines in order to work properly. The second argument is a --- callback that receives a custom space-consuming parser as argument. This --- parser should be used after separate components of line fold that can be --- put on different lines. +-- callback that receives a custom space-consuming parser as an argument. +-- This parser should be used after separate components of line fold that +-- can be put on different lines. -- -- An example should clarify the usage pattern: -- @@ -364,11 +309,13 @@ -- > L.symbol sc "baz" -- for the last symbol we use normal space consumer -- -- @since 5.0.0 - -lineFold :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> (m () -> m a) -- ^ Callback that uses provided space-consumer - -> m a +lineFold :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | Callback that uses provided space-consumer + (m () -> m a) -> + m a lineFold sc action = sc >> indentLevel >>= action . void . indentGuard sc GT {-# INLINEABLE lineFold #-} @@ -392,45 +339,68 @@ -- -- __Performance note__: the parser is not particularly efficient at the -- moment. - charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint, -- and we do know that r will be non-empty if count' succeeds. - r <- lookAhead (count' 1 8 C.anyChar) + r <- lookAhead (count' 1 10 anySingle) case listToMaybe (Char.readLitChar r) of - Just (c, r') -> c <$ skipCount (length r - length r') C.anyChar - Nothing -> unexpected (Tokens (head r:|[])) + Just (c, r') -> c <$ skipCount (length r - length r') anySingle + Nothing -> unexpected (Tokens (head r :| [])) {-# INLINEABLE charLiteral #-} ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of --- integer literals described in the Haskell report. +-- | Parse an integer in the decimal representation according to the format +-- of integer literals described in the Haskell report. -- --- If you need to parse signed integers, see 'signed' combinator. +-- If you need to parse signed integers, see the 'signed' combinator. -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it --- wasn't polymorphic in its return type. - -decimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a) - => m a +-- __Note__: before the version /6.0.0/ the function returned 'Integer', +-- i.e. it wasn't polymorphic in its return type. +-- +-- __Warning__: this function does not perform range checks. +decimal :: (MonadParsec e s m, Token s ~ Char, Num a) => m a decimal = decimal_ "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers. - -decimal_ - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a) - => m a +decimal_ :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a decimal_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 10 + fromIntegral (Char.digitToInt c) +{-# INLINE decimal_ #-} --- | Parse an integer in octal representation. Representation of octal +-- | Parse an integer in binary representation. The binary number is +-- expected to be a non-empty sequence of zeroes “0” and ones “1”. +-- +-- You could of course parse some prefix before the actual number: +-- +-- > binary = char '0' >> char' 'b' >> L.binary +-- +-- __Warning__: this function does not perform range checks. +-- +-- @since 7.0.0 +binary :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +binary = + mkNum + <$> takeWhile1P Nothing isBinDigit + "binary integer" + where + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a c = a * 2 + fromIntegral (Char.digitToInt c) + isBinDigit x = x == '0' || x == '1' +{-# INLINEABLE binary #-} + +-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing @@ -440,21 +410,24 @@ -- -- > octal = char '0' >> char' 'o' >> L.octal -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type. - -octal - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a) - => m a -octal = mkNum - <$> takeWhile1P Nothing Char.isOctDigit - "octal integer" +-- +-- __Warning__: this function does not perform range checks. +octal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +octal = + mkNum + <$> takeWhile1P Nothing Char.isOctDigit + "octal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 8 + fromIntegral (Char.digitToInt c) {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of +-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before @@ -464,17 +437,20 @@ -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type. - -hexadecimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a) - => m a -hexadecimal = mkNum - <$> takeWhile1P Nothing Char.isHexDigit - "hexadecimal integer" +-- +-- __Warning__: this function does not perform range checks. +hexadecimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +hexadecimal = + mkNum + <$> takeWhile1P Nothing Char.isHexDigit + "hexadecimal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 16 + fromIntegral (Char.digitToInt c) {-# INLINEABLE hexadecimal #-} @@ -490,14 +466,14 @@ -- see 'signed'. -- -- @since 5.0.0 - -scientific - :: forall e s m. (MonadParsec e s m, Token s ~ Char) - => m Scientific +scientific :: + forall e s m. + (MonadParsec e s m, Token s ~ Char) => + m Scientific scientific = do - c' <- decimal_ + c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c') - e <- option e' (try $ exponent_ e') + e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -509,46 +485,52 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- --- __Note__: before version 6.0.0 the function returned 'Double', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Double', i.e. it -- wasn't polymorphic in its return type. -- --- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers. - +-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain +-- integers. float :: (MonadParsec e s m, Token s ~ Char, RealFloat a) => m a float = do c' <- decimal_ - Sci.toRealFloat <$> - ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' - e <- option e' (try $ exponent_ e') - return (Sci.scientific c e)) - <|> (Sci.scientific c' <$> exponent_ 0)) + Sci.toRealFloat + <$> ( ( do + SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' + e <- option e' (try $ exponent_ e') + return (Sci.scientific c e) + ) + <|> (Sci.scientific c' <$> exponent_ 0) + ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Char) - => Proxy s - -> Integer - -> m SP +dotDecimal_ :: + (MonadParsec e s m, Token s ~ Char) => + Proxy s -> + Integer -> + m SP dotDecimal_ pxy c' = do void (C.char '.') - let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy - step (SP a e') c = SP - (a * 10 + fromIntegral (Char.digitToInt c)) - (e' - 1) + let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy + step (SP a e') c = + SP + (a * 10 + fromIntegral (Char.digitToInt c)) + (e' - 1) mkNum <$> takeWhile1P (Just "digit") Char.isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Char) - => Int - -> m Int +exponent_ :: + (MonadParsec e s m, Token s ~ Char) => + Int -> + m Int exponent_ e' = do void (C.char' 'e') (+ e') <$> signed (return ()) decimal_ {-# INLINE exponent_ #-} --- | @'signed' space p@ parser parses an optional sign character (“+” or --- “-”), then if there is a sign it consumes optional white space (using --- @space@ parser), then it runs parser @p@ which should return a number. --- Sign of the number is changed according to the previously parsed sign +-- | @'signed' space p@ parses an optional sign character (“+” or “-”), then +-- if there is a sign it consumes optional white space (using the @space@ +-- parser), then it runs the parser @p@ which should return a number. Sign +-- of the number is changed according to the previously parsed sign -- character. -- -- For example, to parse signed integer you can write: @@ -556,11 +538,14 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer - -signed :: (MonadParsec e s m, Token s ~ Char, Num a) - => m () -- ^ How to consume white space after the sign - -> m a -- ^ How to parse the number itself - -> m a -- ^ Parser for signed numbers +signed :: + (MonadParsec e s m, Token s ~ Char, Num a) => + -- | How to consume white space after the sign + m () -> + -- | How to parse the number itself + m a -> + -- | Parser for signed numbers + m a signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ C.char '+') <|> (negate <$ C.char '-') diff --git a/Text/Megaparsec/Class.hs b/Text/Megaparsec/Class.hs --- a/Text/Megaparsec/Class.hs +++ b/Text/Megaparsec/Class.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Class --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -13,86 +20,54 @@ -- the full set of primitive parsers. -- -- @since 6.5.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.Class - ( MonadParsec (..) ) + ( MonadParsec (..), + ) where -import Control.Applicative import Control.Monad import Control.Monad.Identity +import qualified Control.Monad.RWS.Lazy as L +import qualified Control.Monad.RWS.Strict as S import Control.Monad.Trans +import qualified Control.Monad.Trans.Reader as L +import qualified Control.Monad.Trans.State.Lazy as L +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Lazy as L +import qualified Control.Monad.Trans.Writer.Strict as S import Data.Set (Set) import Text.Megaparsec.Error +import {-# SOURCE #-} Text.Megaparsec.Internal (Reply) import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.Trans.Reader as L -import qualified Control.Monad.Trans.State.Lazy as L -import qualified Control.Monad.Trans.State.Strict as S -import qualified Control.Monad.Trans.Writer.Lazy as L -import qualified Control.Monad.Trans.Writer.Strict as S -#if !MIN_VERSION_mtl(2,2,2) -import Control.Monad.Trans.Identity -#endif - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif - -- | Type class describing monads that implement the full set of primitive -- parsers. -- --- __Note carefully__ that the following primitives are “fast” and should be --- taken advantage of as much as possible if your aim is a fast parser: --- 'tokens', 'takeWhileP', 'takeWhile1P', and 'takeP'. - -class (Stream s, Alternative m, MonadPlus m) - => MonadParsec e s m | m -> e s where - - -- | The most general way to stop parsing and report a trivial - -- 'ParseError'. - -- - -- @since 6.0.0 - - failure - :: Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) - -> Set (ErrorItem (Token s)) -- ^ Expected items - -> m a - - -- | The most general way to stop parsing and report a fancy 'ParseError'. - -- To report a single custom parse error, see 'customFailure'. +-- __Note__ that the following primitives are “fast” and should be taken +-- advantage of as much as possible if your aim is a fast parser: 'tokens', +-- 'takeWhileP', 'takeWhile1P', and 'takeP'. +class (Stream s, MonadPlus m) => MonadParsec e s m | m -> e s where + -- | Stop parsing and report the 'ParseError'. This is the only way to + -- control position of the error without manipulating the parser state + -- manually. -- - -- @since 6.0.0 - - fancyFailure - :: Set (ErrorFancy e) -- ^ Fancy error components - -> m a + -- @since 8.0.0 + parseError :: ParseError s e -> m a -- | The parser @'label' name p@ behaves as parser @p@, but whenever the -- parser @p@ fails /without consuming any input/, it replaces names of -- “expected” tokens with the name @name@. - label :: String -> m a -> m a -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any -- “expected” tokens in error message when @p@ fails. -- -- Please use 'hidden' instead of the old @'label' ""@ idiom. - hidden :: m a -> m a hidden = label "" - -- | The parser @'try' p@ behaves like parser @p@, except that it + -- | The parser @'try' p@ behaves like the parser @p@, except that it -- backtracks the parser state when @p@ fails (either consuming input or -- not). -- @@ -125,12 +100,11 @@ -- unexpected "le" -- expecting "let" or "lexical" -- - -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks - -- automatically (see 'tokens'), so it does not need 'try'. However, the - -- examples above demonstrate the idea behind 'try' so well that it was - -- decided to keep them. You still need to use 'try' when your + -- __Note__ that as of Megaparsec 4.4.0, 'Text.Megaparsec.Char.string' + -- backtracks automatically (see 'tokens'), so it does not need 'try'. + -- However, the examples above demonstrate the idea behind 'try' so well + -- that it was decided to keep them. You still need to use 'try' when your -- alternatives are complex, composite parsers. - try :: m a -> m a -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not) @@ -138,81 +112,76 @@ -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no -- effect, i.e. it will fail consuming input if @p@ fails consuming input. -- Combine with 'try' if this is undesirable. - lookAhead :: m a -> m a -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This -- parser /never consumes/ any input and /never modifies/ parser state. It -- can be used to implement the “longest match” rule. - notFollowedBy :: m a -> m () - -- | @'withRecovery' r p@ allows continue parsing even if parser @p@ - -- fails. In this case @r@ is called with the actual 'ParseError' as its - -- argument. Typical usage is to return a value signifying failure to + -- | @'withRecovery' r p@ allows us to continue parsing even if the parser + -- @p@ fails. In this case @r@ is called with the actual 'ParseError' as + -- its argument. Typical usage is to return a value signifying failure to -- parse this particular object and to consume some part of the input up -- to the point where the next object starts. -- - -- Note that if @r@ fails, original error message is reported as if - -- without 'withRecovery'. In no way recovering parser @r@ can influence + -- Note that if @r@ fails, the original error message is reported as if + -- without 'withRecovery'. In no way can the recovering parser @r@ influence -- error messages. -- -- @since 4.4.0 - - withRecovery - :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure - -> m a -- ^ Original parser - -> m a -- ^ Parser that can recover from failures + withRecovery :: + -- | How to recover from failure + (ParseError s e -> m a) -> + -- | Original parser + m a -> + -- | Parser that can recover from failures + m a - -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should - -- it happen, without actually ending parsing, but instead getting the - -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' - -- as usual. Note that this primitive just allows you to observe parse - -- errors as they happen, it does not backtrack or change how the @p@ - -- parser works in any way. + -- | @'observing' p@ allows us to “observe” failure of the @p@ parser, + -- should it happen, without actually ending parsing but instead getting + -- the 'ParseError' in 'Left'. On success parsed value is returned in + -- 'Right' as usual. Note that this primitive just allows you to observe + -- parse errors as they happen, it does not backtrack or change how the + -- @p@ parser works in any way. -- -- @since 5.1.0 - - observing - :: m a -- ^ The parser to run - -> m (Either (ParseError (Token s) e) a) - - -- | This parser only succeeds at the end of the input. + observing :: + -- | The parser to run + m a -> + m (Either (ParseError s e) a) + -- | This parser only succeeds at the end of input. eof :: m () - -- | The parser @'token' test mrep@ accepts a token @t@ with result @x@ - -- when the function @test t@ returns @'Right' x@. @mrep@ may provide - -- representation of the token to report in error messages when input - -- stream in empty. + -- | The parser @'token' test expected@ accepts tokens for which the + -- matching function @test@ returns 'Just' results. If 'Nothing' is + -- returned the @expected@ set is used to report the items that were + -- expected. -- - -- This is the most primitive combinator for accepting tokens. For - -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: + -- For example, the 'Text.Megaparsec.satisfy' parser is implemented as: -- - -- > satisfy f = token testChar Nothing + -- > satisfy f = token testToken Set.empty -- > where - -- > testChar x = - -- > if f x - -- > then Right x - -- > else Left (pure (Tokens (x:|[])), Set.empty) - - token - :: (Token s -> Either ( Maybe (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) ) a) - -- ^ Matching function for the token to parse, it allows to construct - -- arbitrary error message on failure as well; things in the tuple - -- are: unexpected item (if any) and expected items - -> Maybe (Token s) -- ^ Token to report when input stream is empty - -> m a + -- > testToken x = if f x then Just x else Nothing + -- + -- __Note__: type signature of this primitive was changed in the version + -- /7.0.0/. + token :: + -- | Matching function for the token to parse + (Token s -> Maybe a) -> + -- | Used in the error message to mention the items that were expected + Set (ErrorItem (Token s)) -> + m a - -- | The parser @'tokens' test@ parses a chunk of input and returns it. - -- Supplied predicate @test@ is used to check equality of given and parsed - -- chunks after a candidate chunk of correct length is fetched from the - -- stream. + -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and + -- returns it. The supplied predicate @test@ is used to check equality of + -- given and parsed chunks after a candidate chunk of correct length is + -- fetched from the stream. -- - -- This can be used for example to write 'Text.Megaparsec.Char.string': + -- This can be used for example to write 'Text.Megaparsec.chunk': -- - -- > string = tokens (==) + -- > chunk = tokens (==) -- -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking -- primitive, which means that if it fails, it never consumes any input. @@ -229,260 +198,282 @@ -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect -- performance in any way. - - tokens - :: (Tokens s -> Tokens s -> Bool) - -- ^ Predicate to check equality of chunks - -> Tokens s - -- ^ Chunk of input to match against - -> m (Tokens s) + tokens :: + -- | Predicate to check equality of chunks + (Tokens s -> Tokens s -> Bool) -> + -- | Chunk of input to match against + Tokens s -> + m (Tokens s) -- | Parse /zero/ or more tokens for which the supplied predicate holds. - -- Try to use this as much as possible because for many streams the - -- combinator is much faster than parsers built with 'many' and - -- 'Text.Megaparsec.Char.satisfy'. - -- - -- The following equations should clarify the behavior: + -- Try to use this as much as possible because for many streams this + -- combinator is much faster than parsers built with + -- 'Control.Monad.Combinators.many' and 'Text.Megaparsec.satisfy'. -- -- > takeWhileP (Just "foo") f = many (satisfy f "foo") -- > takeWhileP Nothing f = many (satisfy f) -- - -- The combinator never fails, although it may parse an empty chunk. + -- The combinator never fails, although it may parse the empty chunk. -- -- @since 6.0.0 - - takeWhileP - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens + takeWhileP :: + -- | Name for a single token in the row + Maybe String -> + -- | Predicate to use to test tokens + (Token s -> Bool) -> + -- | A chunk of matching tokens + m (Tokens s) -- | Similar to 'takeWhileP', but fails if it can't parse at least one - -- token. Note that the combinator either succeeds or fails without - -- consuming any input, so 'try' is not necessary with it. + -- token. Try to use this as much as possible because for many streams + -- this combinator is much faster than parsers built with + -- 'Control.Monad.Combinators.some' and 'Text.Megaparsec.satisfy'. -- + -- > takeWhile1P (Just "foo") f = some (satisfy f "foo") + -- > takeWhile1P Nothing f = some (satisfy f) + -- + -- Note that the combinator either succeeds or fails without consuming any + -- input, so 'try' is not necessary with it. + -- -- @since 6.0.0 - - takeWhile1P - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens + takeWhile1P :: + -- | Name for a single token in the row + Maybe String -> + -- | Predicate to use to test tokens + (Token s -> Bool) -> + -- | A chunk of matching tokens + m (Tokens s) -- | Extract the specified number of tokens from the input stream and - -- return them packed as a chunk of stream. If there is not enough tokens + -- return them packed as a chunk of stream. If there are not enough tokens -- in the stream, a parse error will be signaled. It's guaranteed that if -- the parser succeeds, the requested number of tokens will be returned. -- -- The parser is roughly equivalent to: -- - -- > takeP (Just "foo") n = count n (anyChar "foo") - -- > takeP Nothing n = count n anyChar + -- > takeP (Just "foo") n = count n (anySingle "foo") + -- > takeP Nothing n = count n anySingle -- -- Note that if the combinator fails due to insufficient number of tokens -- in the input stream, it backtracks automatically. No 'try' is necessary -- with 'takeP'. -- -- @since 6.0.0 - - takeP - :: Maybe String -- ^ Name for a single token in the row - -> Int -- ^ How many tokens to extract - -> m (Tokens s) -- ^ A chunk of matching tokens + takeP :: + -- | Name for a single token in the row + Maybe String -> + -- | How many tokens to extract + Int -> + -- | A chunk of matching tokens + m (Tokens s) -- | Return the full parser state as a 'State' record. - - getParserState :: m (State s) + getParserState :: m (State s e) -- | @'updateParserState' f@ applies the function @f@ to the parser state. + updateParserState :: (State s e -> State s e) -> m () - updateParserState :: (State s -> State s) -> m () + -- | An escape hatch for defining custom 'MonadParsec' primitives. You + -- will need to import "Text.Megaparsec.Internal" in order to construct + -- 'Reply'. + -- + -- @since 9.4.0 + mkParsec :: (State s e -> Reply e s a) -> m a ---------------------------------------------------------------------------- -- Lifting through MTL -instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.StateT m) = L.StateT $ label n . m - try (L.StateT m) = L.StateT $ try . m - lookAhead (L.StateT m) = L.StateT $ \s -> +instance (MonadParsec e s m) => MonadParsec e s (L.StateT st m) where + parseError e = lift (parseError e) + label n (L.StateT m) = L.StateT $ label n . m + try (L.StateT m) = L.StateT $ try . m + lookAhead (L.StateT m) = L.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (L.StateT m) = L.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (L.StateT m) = L.StateT $ \s -> withRecovery (\e -> L.runStateT (r e) s) (m s) - observing (L.StateT m) = L.StateT $ \s -> + observing (L.StateT m) = L.StateT $ \s -> fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.StateT m) = S.StateT $ label n . m - try (S.StateT m) = S.StateT $ try . m - lookAhead (S.StateT m) = S.StateT $ \s -> +instance (MonadParsec e s m) => MonadParsec e s (S.StateT st m) where + parseError e = lift (parseError e) + label n (S.StateT m) = S.StateT $ label n . m + try (S.StateT m) = S.StateT $ try . m + lookAhead (S.StateT m) = S.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (S.StateT m) = S.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (S.StateT m) = S.StateT $ \s -> withRecovery (\e -> S.runStateT (r e) s) (m s) - observing (S.StateT m) = S.StateT $ \s -> + observing (S.StateT m) = S.StateT $ \s -> fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.ReaderT m) = L.ReaderT $ label n . m - try (L.ReaderT m) = L.ReaderT $ try . m - lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m +instance (MonadParsec e s m) => MonadParsec e s (L.ReaderT r m) where + parseError e = lift (parseError e) + label n (L.ReaderT m) = L.ReaderT $ label n . m + try (L.ReaderT m) = L.ReaderT $ try . m + lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> withRecovery (\e -> L.runReaderT (r e) s) (m s) - observing (L.ReaderT m) = L.ReaderT $ observing . m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + observing (L.ReaderT m) = L.ReaderT $ observing . m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.WriterT m) = L.WriterT $ label n m - try (L.WriterT m) = L.WriterT $ try m - lookAhead (L.WriterT m) = L.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (L.WriterT m) = L.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (L.WriterT m) = L.WriterT $ - withRecovery (L.runWriterT . r) m - observing (L.WriterT m) = L.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + parseError e = lift (parseError e) + label n (L.WriterT m) = L.WriterT $ label n m + try (L.WriterT m) = L.WriterT $ try m + lookAhead (L.WriterT m) = + L.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (L.WriterT m) = + L.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (L.WriterT m) = + L.WriterT $ + withRecovery (L.runWriterT . r) m + observing (L.WriterT m) = + L.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.WriterT m) = S.WriterT $ label n m - try (S.WriterT m) = S.WriterT $ try m - lookAhead (S.WriterT m) = S.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (S.WriterT m) = S.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (S.WriterT m) = S.WriterT $ - withRecovery (S.runWriterT . r) m - observing (S.WriterT m) = S.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + parseError e = lift (parseError e) + label n (S.WriterT m) = S.WriterT $ label n m + try (S.WriterT m) = S.WriterT $ try m + lookAhead (S.WriterT m) = + S.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (S.WriterT m) = + S.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (S.WriterT m) = + S.WriterT $ + withRecovery (S.runWriterT . r) m + observing (S.WriterT m) = + S.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -- | @since 5.2.0 - instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) - try (L.RWST m) = L.RWST $ \r s -> try (m r s) - lookAhead (L.RWST m) = L.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (L.RWST m) = L.RWST $ \r s -> do + parseError e = lift (parseError e) + label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) + try (L.RWST m) = L.RWST $ \r s -> try (m r s) + lookAhead (L.RWST m) = L.RWST $ \r s -> do + (x, _, _) <- lookAhead (m r s) + return (x, s, mempty) + notFollowedBy (L.RWST m) = L.RWST $ \r s -> do notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (L.RWST m) = L.RWST $ \r s -> + return ((), s, mempty) + withRecovery n (L.RWST m) = L.RWST $ \r s -> withRecovery (\e -> L.runRWST (n e) r s) (m r s) - observing (L.RWST m) = L.RWST $ \r s -> + observing (L.RWST m) = L.RWST $ \r s -> fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -- | @since 5.2.0 - instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) - try (S.RWST m) = S.RWST $ \r s -> try (m r s) - lookAhead (S.RWST m) = S.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (S.RWST m) = S.RWST $ \r s -> do + parseError e = lift (parseError e) + label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) + try (S.RWST m) = S.RWST $ \r s -> try (m r s) + lookAhead (S.RWST m) = S.RWST $ \r s -> do + (x, _, _) <- lookAhead (m r s) + return (x, s, mempty) + notFollowedBy (S.RWST m) = S.RWST $ \r s -> do notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (S.RWST m) = S.RWST $ \r s -> + return ((), s, mempty) + withRecovery n (S.RWST m) = S.RWST $ \r s -> withRecovery (\e -> S.runRWST (n e) r s) (m r s) - observing (S.RWST m) = S.RWST $ \r s -> + observing (S.RWST m) = S.RWST $ \r s -> fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (IdentityT m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (IdentityT m) = IdentityT $ label n m - try = IdentityT . try . runIdentityT - lookAhead (IdentityT m) = IdentityT $ lookAhead m +instance (MonadParsec e s m) => MonadParsec e s (IdentityT m) where + parseError e = lift (parseError e) + label n (IdentityT m) = IdentityT $ label n m + try = IdentityT . try . runIdentityT + lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - withRecovery r (IdentityT m) = IdentityT $ - withRecovery (runIdentityT . r) m - observing (IdentityT m) = IdentityT $ observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift $ tokens e ts - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift $ updateParserState f + withRecovery r (IdentityT m) = + IdentityT $ + withRecovery (runIdentityT . r) m + observing (IdentityT m) = IdentityT $ observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift $ tokens e ts + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + mkParsec f = lift (mkParsec f) fixs :: s -> Either a (b, s) -> (Either a b, s) -fixs s (Left a) = (Left a, s) +fixs s (Left a) = (Left a, s) fixs _ (Right (b, s)) = (Right b, s) {-# INLINE fixs #-} -fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) -fixs' s (Left a) = (Left a, s, mempty) -fixs' _ (Right (b,s,w)) = (Right b, s, w) +fixs' :: (Monoid w) => s -> Either a (b, s, w) -> (Either a b, s, w) +fixs' s (Left a) = (Left a, s, mempty) +fixs' _ (Right (b, s, w)) = (Right b, s, w) {-# INLINE fixs' #-} 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,176 +1,222 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Error --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- --- Parse errors. Current version of Megaparsec supports well-typed errors +-- Parse errors. The current version of Megaparsec supports typed errors -- instead of 'String'-based ones. This gives a lot of flexibility in -- describing what exactly went wrong as well as a way to return arbitrary -- data in case of failure. -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Text.Megaparsec.Error ( -- * Parse error type - ErrorItem (..) - , ErrorFancy (..) - , ParseError (..) - , errorPos + ErrorItem (..), + ErrorFancy (..), + ParseError (..), + mapParseError, + errorOffset, + setErrorOffset, + ParseErrorBundle (..), + attachSourcePos, + -- * Pretty-printing - , ShowToken (..) - , LineToken (..) - , ShowErrorComponent (..) - , parseErrorPretty - , parseErrorPretty' - , parseErrorPretty_ - , sourcePosStackPretty - , parseErrorTextPretty ) + ShowErrorComponent (..), + errorBundlePretty, + errorBundlePrettyForGhcPreProcessors, + errorBundlePrettyWith, + parseErrorPretty, + parseErrorTextPretty, + showErrorItem, + ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception -import Data.Char (chr) +import Control.Monad.State.Strict import Data.Data (Data) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, isNothing) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isNothing) import Data.Proxy -import Data.Semigroup import Data.Set (Set) +import qualified Data.Set as E import Data.Typeable (Typeable) import Data.Void -import Data.Word (Word8) import GHC.Generics -import Prelude hiding (concat) import Text.Megaparsec.Pos +import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import qualified Text.Megaparsec.Unicode as Unicode ---------------------------------------------------------------------------- -- Parse error type --- | Data type that is used to represent “unexpected\/expected” items in --- 'ParseError'. The data type is parametrized over the token type @t@. +-- | A data type that is used to represent “unexpected\/expected” items in +-- 'ParseError'. It is parametrized over the token type @t@. -- -- @since 5.0.0 - data ErrorItem t - = Tokens (NonEmpty t) -- ^ Non-empty stream of tokens - | Label (NonEmpty Char) -- ^ Label (cannot be empty) - | EndOfInput -- ^ End of input - deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) + = -- | Non-empty stream of tokens + Tokens (NonEmpty t) + | -- | Label (cannot be empty) + Label (NonEmpty Char) + | -- | End of input + EndOfInput + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData t => NFData (ErrorItem t) +instance (NFData t) => NFData (ErrorItem t) -- | Additional error data, extendable by user. When no custom data is -- necessary, the type is typically indexed by 'Void' to “cancel” the -- 'ErrorCustom' constructor. -- -- @since 6.0.0 - data ErrorFancy e - = ErrorFail String - -- ^ 'fail' has been used in parser monad - | ErrorIndentation Ordering Pos Pos - -- ^ Incorrect indentation error: desired ordering between reference + = -- | 'fail' has been used in parser monad + ErrorFail String + | -- | Incorrect indentation error: desired ordering between reference -- level and actual level, reference indentation level, actual -- indentation level - | ErrorCustom e - -- ^ Custom error data, can be conveniently disabled by indexing - -- 'ErrorFancy' by 'Void' - deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) + ErrorIndentation Ordering Pos Pos + | -- | Custom error data + ErrorCustom e + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData a => NFData (ErrorFancy a) where +instance (NFData a) => NFData (ErrorFancy a) where rnf (ErrorFail str) = rnf str rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act rnf (ErrorCustom a) = rnf a --- | @'ParseError' t e@ represents a parse error parametrized over the token --- type @t@ and the custom data @e@. --- --- Note that the stack of source positions contains current position as its --- head, and the rest of positions allows to track full sequence of include --- files with topmost source file at the end of the list. +-- | @'ParseError' s e@ represents a parse error parametrized over the +-- stream type @s@ and the custom data @e@. -- --- 'Semigroup' and 'Monoid' instances of the data type allow to merge parse --- errors from different branches of parsing. When merging two +-- 'Semigroup' and 'Monoid' instances of the data type allow us to merge +-- parse errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. Note that -- fancy errors take precedence over trivial errors in merging. -- --- @since 6.0.0 +-- @since 7.0.0 +data ParseError s e + = -- | Trivial errors, generated by the Megaparsec's machinery. The data + -- constructor includes the offset of error, unexpected token (if any), + -- and expected tokens. + -- + -- Type of the first argument was changed in the version /7.0.0/. + TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) + | -- | Fancy, custom errors. + -- + -- Type of the first argument was changed in the version /7.0.0/. + FancyError Int (Set (ErrorFancy e)) + deriving (Generic) -data ParseError t e - = TrivialError (NonEmpty SourcePos) (Maybe (ErrorItem t)) (Set (ErrorItem t)) - -- ^ Trivial errors, generated by Megaparsec's machinery. The data - -- constructor includes the stack of source positions, unexpected token - -- (if any), and expected tokens. - | FancyError (NonEmpty SourcePos) (Set (ErrorFancy e)) - -- ^ Fancy, custom errors. - deriving (Show, Read, Eq, Data, Typeable, Generic) +deriving instance + ( Show (Token s), + Show e + ) => + Show (ParseError s e) -instance (NFData t, NFData e) => NFData (ParseError t e) +deriving instance + ( Eq (Token s), + Eq e + ) => + Eq (ParseError s e) -instance (Ord t, Ord e) => Semigroup (ParseError t e) where +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseError s e) + +instance + ( NFData (Token s), + NFData e + ) => + NFData (ParseError s e) + +instance (Stream s, Ord e) => Semigroup (ParseError s e) where (<>) = mergeError {-# INLINE (<>) #-} -instance (Ord t, Ord e) => Monoid (ParseError t e) where - mempty = TrivialError (initialPos "" :| []) Nothing E.empty +instance (Stream s, Ord e) => Monoid (ParseError s e) where + mempty = TrivialError 0 Nothing E.empty mappend = (<>) {-# INLINE mappend #-} -instance ( Show t - , Ord t - , ShowToken t - , Typeable t - , Show e - , ShowErrorComponent e - , Typeable e ) - => Exception (ParseError t e) where -#if MIN_VERSION_base(4,8,0) +instance + ( Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + Typeable s, + Typeable e + ) => + Exception (ParseError s e) + where displayException = parseErrorPretty -#endif --- | Get position of given 'ParseError'. +-- | Modify the custom data component in a parse error. This could be done +-- via 'fmap' if not for the 'Ord' constraint. -- --- @since 6.0.0 +-- @since 7.0.0 +mapParseError :: + (Ord e') => + (e -> e') -> + ParseError s e -> + ParseError s e' +mapParseError _ (TrivialError o u p) = TrivialError o u p +mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) -errorPos :: ParseError t e -> NonEmpty SourcePos -errorPos (TrivialError p _ _) = p -errorPos (FancyError p _) = p +-- | Get the offset of a 'ParseError'. +-- +-- @since 7.0.0 +errorOffset :: ParseError s e -> Int +errorOffset (TrivialError o _ _) = o +errorOffset (FancyError o _) = o +-- | Set the offset of a 'ParseError'. +-- +-- @since 8.0.0 +setErrorOffset :: Int -> ParseError s e -> ParseError s e +setErrorOffset o (TrivialError _ u p) = TrivialError o u p +setErrorOffset o (FancyError _ x) = FancyError o x + -- | Merge two error data structures into one joining their collections of -- message items and preferring the longest match. In other words, earlier -- error message is discarded. This may seem counter-intuitive, but -- 'mergeError' is only used to merge error messages of alternative branches -- of parsing and in this case longest match should be preferred. - -mergeError :: (Ord t, Ord e) - => ParseError t e - -> ParseError t e - -> ParseError t e +mergeError :: + (Stream s, Ord e) => + ParseError s e -> + ParseError s e -> + ParseError s e mergeError e1 e2 = - case errorPos e1 `compare` errorPos e2 of + case errorOffset e1 `compare` errorOffset e2 of LT -> e2 EQ -> case (e1, e2) of @@ -190,304 +236,341 @@ -- arbitrary, but is necessary because otherwise we can't make -- ParseError lawful Monoid and have nice parse errors at the same -- time). - n Nothing Nothing = Nothing + n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} ----------------------------------------------------------------------------- --- Pretty-printing - --- | Type class 'ShowToken' includes methods that allow to pretty-print --- single token as well as stream of tokens. This is used for rendering of --- error messages. +-- | A non-empty collection of 'ParseError's equipped with 'PosState' that +-- allows us to pretty-print the errors efficiently and correctly. -- --- @since 5.0.0 +-- @since 7.0.0 +data ParseErrorBundle s e = ParseErrorBundle + { -- | A collection of 'ParseError's that is sorted by parse error offsets + bundleErrors :: NonEmpty (ParseError s e), + -- | The state that is used for line\/column calculation + bundlePosState :: PosState s + } + deriving (Generic) -class ShowToken a where +deriving instance + ( Show s, + Show (Token s), + Show e + ) => + Show (ParseErrorBundle s e) - -- | Pretty-print non-empty stream of tokens. This function is also used - -- to print single tokens (represented as singleton lists). +deriving instance + ( Eq s, + Eq (Token s), + Eq e + ) => + Eq (ParseErrorBundle s e) - showTokens :: NonEmpty a -> String +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseErrorBundle s e) -instance ShowToken Char where - showTokens = stringPretty +instance + ( NFData s, + NFData (Token s), + NFData e + ) => + NFData (ParseErrorBundle s e) -instance ShowToken Word8 where - showTokens = stringPretty . fmap (chr . fromIntegral) +instance + ( Show s, + Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + TraversableStream s, + Typeable s, + Typeable e + ) => + Exception (ParseErrorBundle s e) + where + displayException = errorBundlePretty --- | Type class for tokens that support operations necessary for selecting --- and displaying relevant line of input. +-- | Attach 'SourcePos'es to items in a 'Traversable' container given that +-- there is a projection allowing us to get an offset per item. -- --- @since 6.0.0 - -class LineToken a where - - -- | Convert a token to a 'Char'. This is used to print relevant line from - -- input stream by turning a list of tokens into a 'String'. - - tokenAsChar :: a -> Char - - -- | Check if given token is a newline or contains newline. - - tokenIsNewline :: a -> Bool - -instance LineToken Char where - tokenAsChar = id - tokenIsNewline x = x == '\n' +-- Items must be in ascending order with respect to their offsets. +-- +-- @since 7.0.0 +attachSourcePos :: + (Traversable t, TraversableStream s) => + -- | How to project offset from an item (e.g. 'errorOffset') + (a -> Int) -> + -- | The collection of items + t a -> + -- | Initial 'PosState' + PosState s -> + -- | The collection with 'SourcePos'es added and the final 'PosState' + (t (a, SourcePos), PosState s) +attachSourcePos projectOffset xs = runState (traverse f xs) + where + f a = do + pst <- get + let pst' = reachOffsetNoLine (projectOffset a) pst + put pst' + return (a, pstateSourcePos pst') +{-# INLINEABLE attachSourcePos #-} -instance LineToken Word8 where - tokenAsChar = chr . fromIntegral - tokenIsNewline x = x == 10 +---------------------------------------------------------------------------- +-- Pretty-printing --- | The type class defines how to print custom data component of --- 'ParseError'. +-- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0 - -class Ord a => ShowErrorComponent a where - - -- | Pretty-print custom data component of 'ParseError'. - +class (Ord a) => ShowErrorComponent a where + -- | Pretty-print a component of 'ParseError'. showErrorComponent :: a -> String -instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where - showErrorComponent (Tokens ts) = showTokens ts - showErrorComponent (Label label) = NE.toList label - showErrorComponent EndOfInput = "end of input" - -instance ShowErrorComponent e => ShowErrorComponent (ErrorFancy e) where - showErrorComponent (ErrorFail msg) = msg - showErrorComponent (ErrorIndentation ord ref actual) = - "incorrect indentation (got " <> show (unPos actual) <> - ", should be " <> p <> show (unPos ref) <> ")" - where - p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " - showErrorComponent (ErrorCustom a) = showErrorComponent a + -- | Length of the error component in characters, used for highlighting of + -- parse errors in input string. + -- + -- @since 7.0.0 + errorComponentLen :: a -> Int + errorComponentLen _ = 1 instance ShowErrorComponent Void where showErrorComponent = absurd --- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a --- newline. +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order, by applying a provided format function, with +-- a single pass over the input stream. -- --- @since 5.0.0 - -parseErrorPretty - :: ( Ord t - , ShowToken t - , ShowErrorComponent e ) - => ParseError t e -- ^ Parse error to render - -> String -- ^ Result of rendering -parseErrorPretty e = - sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty e +-- @since 9.7.0 +errorBundlePrettyWith :: + forall s e. + ( VisualStream s, + TraversableStream s + ) => + -- | Format function for a single 'ParseError' + (Maybe String -> SourcePos -> ParseError s e -> String) -> + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyWith format ParseErrorBundle {..} = + let (r, _) = foldl f (id, bundlePosState) bundleErrors + in r "" + where + f :: + (ShowS, PosState s) -> + ParseError s e -> + (ShowS, PosState s) + f (o, !pst) e = (o . (outChunk ++), pst') + where + (msline, pst') = reachOffset (errorOffset e) pst + epos = pstateSourcePos pst' + outChunk = format msline epos e --- | Pretty-print a 'ParseError' and display the line on which the parse --- error occurred. The rendered 'String' always ends with a newline. --- --- Note that if you work with include files and have a stack of --- 'SourcePos'es in 'ParseError', it's up to you to provide correct input --- stream corresponding to the file in which parse error actually happened. --- --- 'parseErrorPretty'' is defined in terms of the more general --- 'parseErrorPretty_' function which allows to specify tab width as well: --- --- > parseErrorPretty' = parseErrorPretty_ defaultTabWidth +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order together with the corresponding offending +-- lines by doing a single pass over the input stream. The rendered 'String' +-- always ends with a newline. -- --- @since 6.0.0 - -parseErrorPretty' - :: ( ShowToken (Token s) - , LineToken (Token s) - , ShowErrorComponent e - , Stream s ) - => s -- ^ Original input stream - -> ParseError (Token s) e -- ^ Parse error to render - -> String -- ^ Result of rendering -parseErrorPretty' = parseErrorPretty_ defaultTabWidth +-- @since 7.0.0 +errorBundlePretty :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePretty = drop 1 . errorBundlePrettyWith format + where + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format msline epos e = outChunk + where + outChunk = + "\n" + <> sourcePosPretty epos + <> ":\n" + <> offendingLine + <> parseErrorTextPretty e + offendingLine = + case msline of + Nothing -> "" + Just sline -> + let rpadding = + if pointerLen > 0 + then replicate rpshift ' ' + else "" + pointerLen = + if rpshift + elen > slineLen + then slineLen - rpshift + 1 + else max 1 elen + pointer = replicate pointerLen '^' + lineNumber = (show . unPos . sourceLine) epos + padding = replicate (length lineNumber + 1) ' ' + rpshift = unPos (sourceColumn epos) - 1 + slineLen = Unicode.stringLength sline + in padding + <> "|\n" + <> lineNumber + <> " | " + <> sline + <> "\n" + <> padding + <> "| " + <> rpadding + <> pointer + <> "\n" + pxy = Proxy :: Proxy s + elen = + case e of + TrivialError _ Nothing _ -> 1 + TrivialError _ (Just x) _ -> errorItemLength pxy x + FancyError _ xs -> + E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs --- | Just like 'parseErrorPretty'', but allows to specify tab width. +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order by doing a single pass over the input stream. -- --- @since 6.1.0 - -parseErrorPretty_ - :: forall s e. - ( ShowToken (Token s) - , LineToken (Token s) - , ShowErrorComponent e - , Stream s ) - => Pos -- ^ Tab width - -> s -- ^ Original input stream - -> ParseError (Token s) e -- ^ Parse error to render - -> String -- ^ Result of rendering -parseErrorPretty_ w s e = - sourcePosStackPretty (errorPos e) <> ":\n" <> - padding <> "|\n" <> - lineNumber <> " | " <> rline <> "\n" <> - padding <> "| " <> rpadding <> "^\n" <> - parseErrorTextPretty e +-- The rendered format is suitable for custom GHC pre-processors (as can be +-- specified with -F -pgmF). +-- +-- @since 9.7.0 +errorBundlePrettyForGhcPreProcessors :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format where - epos = NE.last (errorPos e) - lineNumber = (show . unPos . sourceLine) epos - padding = replicate (length lineNumber + 1) ' ' - rpadding = replicate (unPos (sourceColumn epos) - 1) ' ' - rline = - case rline' of - [] -> "" - xs -> expandTab w xs - rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $ - selectLine (sourceLine epos) s + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format _msline epos e = + sourcePosPretty epos + <> ":" + <> indent (parseErrorTextPretty e) --- | Pretty-print a stack of source positions. + indent :: String -> String + indent = + lines >>> \case + [err] -> err + err -> intercalate "\n" $ map (" " <>) err + +-- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a +-- newline. -- -- @since 5.0.0 - -sourcePosStackPretty :: NonEmpty SourcePos -> String -sourcePosStackPretty ms = mconcat (f <$> rest) <> sourcePosPretty pos - where - (pos :| rest') = ms - rest = reverse rest' - f p = "in file included from " <> sourcePosPretty p <> ",\n" +parseErrorPretty :: + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String +parseErrorPretty e = + "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e -- | Pretty-print a textual part of a 'ParseError', that is, everything --- except stack of source positions. The rendered staring always ends with a --- new line. +-- except for its position. The rendered 'String' always ends with a +-- newline. -- -- @since 5.1.0 - -parseErrorTextPretty - :: ( Ord t - , ShowToken t - , ShowErrorComponent e ) - => ParseError t e -- ^ Parse error to render - -> String -- ^ Result of rendering +parseErrorTextPretty :: + forall s e. + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String parseErrorTextPretty (TrivialError _ us ps) = if isNothing us && E.null ps then "unknown parse error\n" - else messageItemsPretty "unexpected " (maybe E.empty E.singleton us) <> - messageItemsPretty "expecting " ps + else + messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) + <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps) + where + pxy = Proxy :: Proxy s parseErrorTextPretty (FancyError _ xs) = if E.null xs then "unknown fancy parse error\n" - else unlines (showErrorComponent <$> E.toAscList xs) + else unlines (showErrorFancy <$> E.toAscList xs) ---------------------------------------------------------------------------- -- Helpers --- | @stringPretty s@ returns pretty representation of string @s@. This is --- used when printing string tokens in error messages. - -stringPretty :: NonEmpty Char -> String -stringPretty (x:|[]) = charPretty x -stringPretty ('\r':|"\n") = "crlf newline" -stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\"" - where - f ch = - case charPretty' ch of - Nothing -> [ch] - Just pretty -> "<" <> pretty <> ">" - --- | @charPretty ch@ returns user-friendly string representation of given --- character @ch@, suitable for using in error messages. - -charPretty :: Char -> String -charPretty ' ' = "space" -charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch) +-- | Pretty-print an 'ErrorItem'. +-- +-- @since 9.4.0 +showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String +showErrorItem pxy = \case + Tokens ts -> showTokens pxy ts + Label label -> NE.toList label + EndOfInput -> "end of input" --- | If the given character has a pretty representation, return that, --- otherwise 'Nothing'. This is an internal helper. +-- | Get length of the “pointer” to display under a given 'ErrorItem'. +errorItemLength :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> Int +errorItemLength pxy = \case + Tokens ts -> tokensLength pxy ts + _ -> 1 -charPretty' :: Char -> Maybe String -charPretty' '\NUL' = pure "null" -charPretty' '\SOH' = pure "start of heading" -charPretty' '\STX' = pure "start of text" -charPretty' '\ETX' = pure "end of text" -charPretty' '\EOT' = pure "end of transmission" -charPretty' '\ENQ' = pure "enquiry" -charPretty' '\ACK' = pure "acknowledge" -charPretty' '\BEL' = pure "bell" -charPretty' '\BS' = pure "backspace" -charPretty' '\t' = pure "tab" -charPretty' '\n' = pure "newline" -charPretty' '\v' = pure "vertical tab" -charPretty' '\f' = pure "form feed" -charPretty' '\r' = pure "carriage return" -charPretty' '\SO' = pure "shift out" -charPretty' '\SI' = pure "shift in" -charPretty' '\DLE' = pure "data link escape" -charPretty' '\DC1' = pure "device control one" -charPretty' '\DC2' = pure "device control two" -charPretty' '\DC3' = pure "device control three" -charPretty' '\DC4' = pure "device control four" -charPretty' '\NAK' = pure "negative acknowledge" -charPretty' '\SYN' = pure "synchronous idle" -charPretty' '\ETB' = pure "end of transmission block" -charPretty' '\CAN' = pure "cancel" -charPretty' '\EM' = pure "end of medium" -charPretty' '\SUB' = pure "substitute" -charPretty' '\ESC' = pure "escape" -charPretty' '\FS' = pure "file separator" -charPretty' '\GS' = pure "group separator" -charPretty' '\RS' = pure "record separator" -charPretty' '\US' = pure "unit separator" -charPretty' '\DEL' = pure "delete" -charPretty' '\160' = pure "non-breaking space" -charPretty' _ = Nothing +-- | Pretty-print an 'ErrorFancy'. +showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String +showErrorFancy = \case + ErrorFail msg -> msg + ErrorIndentation ord ref actual -> + "incorrect indentation (got " + <> show (unPos actual) + <> ", should be " + <> p + <> show (unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " + ErrorCustom a -> showErrorComponent a --- | Transforms a list of error messages into their textual representation. +-- | Get length of the “pointer” to display under a given 'ErrorFancy'. +errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int +errorFancyLength = \case + ErrorCustom a -> errorComponentLen a + _ -> 1 -messageItemsPretty :: ShowErrorComponent a - => String -- ^ Prefix to prepend - -> Set a -- ^ Collection of messages - -> String -- ^ Result of rendering +-- | Transform a list of error messages into their textual representation. +messageItemsPretty :: + -- | Prefix to prepend + String -> + -- | Collection of messages + Set String -> + -- | Result of rendering + String messageItemsPretty prefix ts | E.null ts = "" | otherwise = - let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent - in prefix <> f ts <> "\n" + prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n" -- | Print a pretty list where items are separated with commas and the word -- “or” according to the rules of English punctuation. - orList :: NonEmpty String -> String -orList (x:|[]) = x -orList (x:|[y]) = x <> " or " <> y -orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs - --- | Select a line from input stream given its number. - -selectLine - :: forall s. (LineToken (Token s), Stream s) - => Pos -- ^ Number of line to select - -> s -- ^ Input stream - -> Tokens s -- ^ Selected line -selectLine l = go pos1 - where - go !n !s = - if n == l - then fst (takeWhile_ notNewline s) - else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s)) - notNewline = not . tokenIsNewline - stripNewline s = - case take1_ s of - Nothing -> s - Just (_, s') -> s' - --- | Replace tab characters with given number of spaces. - -expandTab - :: Pos - -> String - -> String -expandTab w' = go 0 - where - go 0 [] = [] - go 0 ('\t':xs) = go w xs - go 0 (x:xs) = x : go 0 xs - go !n xs = ' ' : go (n - 1) xs - w = unPos w' +orList (x :| []) = x +orList (x :| [y]) = x <> " or " <> y +orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs 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 --- a/Text/Megaparsec/Error/Builder.hs +++ b/Text/Megaparsec/Error/Builder.hs @@ -1,6 +1,14 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Error.Builder --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -8,207 +16,177 @@ -- Portability : portable -- -- A set of helpers that should make construction of 'ParseError's more --- concise. This is primarily useful in test suites and for debugging, you --- most certainly don't need it for normal usage. +-- concise. This is primarily useful in test suites and for debugging. -- -- @since 6.0.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Text.Megaparsec.Error.Builder ( -- * Top-level helpers - err - , errFancy - -- * Error position - , posI - , posN + err, + errFancy, + -- * Error components - , utok - , utoks - , ulabel - , ueof - , etok - , etoks - , elabel - , eeof - , fancy + utok, + utoks, + ulabel, + ueof, + etok, + etoks, + elabel, + eeof, + fancy, + -- * Data types - , ET - , EF ) + ET, + EF, + ) where import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Set (Set) -import Data.Typeable (Typeable) +import qualified Data.Set as E import GHC.Generics import Text.Megaparsec.Error -import Text.Megaparsec.Pos import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - ---------------------------------------------------------------------------- -- Data types -- | Auxiliary type for construction of trivial parse errors. +data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) + deriving (Generic) -data ET t = ET (Maybe (ErrorItem t)) (Set (ErrorItem t)) - deriving (Eq, Ord, Data, Typeable, Generic) +deriving instance (Eq (Token s)) => Eq (ET s) -instance Ord t => Semigroup (ET t) where +deriving instance (Ord (Token s)) => Ord (ET s) + +deriving instance + ( Data s, + Data (Token s), + Ord (Token s) + ) => + Data (ET s) + +instance (Stream s) => Semigroup (ET s) where ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1) where - n Nothing Nothing = Nothing + n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y) -instance Ord t => Monoid (ET t) where - mempty = ET Nothing E.empty +instance (Stream s) => Monoid (ET s) where + mempty = ET Nothing E.empty mappend = (<>) -- | Auxiliary type for construction of fancy parse errors. - -data EF e = EF (Set (ErrorFancy e)) - deriving (Eq, Ord, Data, Typeable, Generic) +newtype EF e = EF (Set (ErrorFancy e)) + deriving (Eq, Ord, Data, Generic) -instance Ord e => Semigroup (EF e) where +instance (Ord e) => Semigroup (EF e) where EF xs0 <> EF xs1 = EF (E.union xs0 xs1) -instance Ord e => Monoid (EF e) where - mempty = EF E.empty +instance (Ord e) => Monoid (EF e) where + mempty = EF E.empty mappend = (<>) ---------------------------------------------------------------------------- -- Top-level helpers --- | Assemble a 'ParseError' from source position and @'ET' t@ value. To --- create source position, two helpers are available: 'posI' and 'posN'. --- @'ET' t@ is a monoid and can be assembled by combining primitives --- provided by this module, see below. - -err - :: NonEmpty SourcePos -- ^ 'ParseError' position - -> ET t -- ^ Error components - -> ParseError t e -- ^ Resulting 'ParseError' -err pos (ET us ps) = TrivialError pos us ps +-- | Assemble a 'ParseError' from the offset and the @'ET' t@ value. @'ET' +-- t@ is a monoid and can be assembled by combining primitives provided by +-- this module, see below. +err :: + -- | 'ParseError' offset + Int -> + -- | Error components + ET s -> + -- | Resulting 'ParseError' + ParseError s e +err p (ET us ps) = TrivialError p us ps -- | Like 'err', but constructs a “fancy” 'ParseError'. - -errFancy - :: NonEmpty SourcePos -- ^ 'ParseError' position - -> EF e -- ^ Error components - -> ParseError t e -- ^ Resulting 'ParseError' -errFancy pos (EF xs) = FancyError pos xs - ----------------------------------------------------------------------------- --- Error position - --- | Initial source position with empty file name. - -posI :: NonEmpty SourcePos -posI = initialPos "" :| [] - --- | @'posN' n s@ returns source position achieved by applying 'advanceN' --- method corresponding to the type of stream @s@. - -posN :: forall s. Stream s - => Int - -> s - -> NonEmpty SourcePos -posN n s = - case takeN_ n s of - Nothing -> posI - Just (ts, _) -> - advanceN (Proxy :: Proxy s) defaultTabWidth (initialPos "") ts :| [] +errFancy :: + -- | 'ParseError' offset + Int -> + -- | Error components + EF e -> + -- | Resulting 'ParseError' + ParseError s e +errFancy p (EF xs) = FancyError p xs ---------------------------------------------------------------------------- -- Error components -- | Construct an “unexpected token” error component. - -utok :: Ord t => t -> ET t +utok :: Token s -> ET s utok = unexp . Tokens . nes --- | Construct an “unexpected tokens” error component. Empty string produces +-- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'. - -utoks :: Ord t => [t] -> ET t -utoks = unexp . canonicalizeTokens +utoks :: forall s. (Stream s) => Tokens s -> ET s +utoks = unexp . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “unexpected label” error component. Do not use with empty -- strings (for empty strings it's bottom). - -ulabel :: Ord t => String -> ET t -ulabel = unexp . Label . NE.fromList +ulabel :: String -> ET s +ulabel label + | label == "" = error "Text.Megaparsec.Error.Builder.ulabel: empty label" + | otherwise = unexp . Label . NE.fromList $ label -- | Construct an “unexpected end of input” error component. - -ueof :: Ord t => ET t +ueof :: ET s ueof = unexp EndOfInput -- | Construct an “expected token” error component. - -etok :: Ord t => t -> ET t +etok :: Token s -> ET s etok = expe . Tokens . nes --- | Construct an “expected tokens” error component. Empty string produces +-- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'. - -etoks :: Ord t => [t] -> ET t -etoks = expe . canonicalizeTokens +etoks :: forall s. (Stream s) => Tokens s -> ET s +etoks = expe . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “expected label” error component. Do not use with empty -- strings. - -elabel :: Ord t => String -> ET t -elabel = expe . Label . NE.fromList +elabel :: String -> ET s +elabel label + | label == "" = error "Text.Megaparsec.Error.Builder.elabel: empty label" + | otherwise = expe . Label . NE.fromList $ label -- | Construct an “expected end of input” error component. - -eeof :: Ord t => ET t +eeof :: ET s eeof = expe EndOfInput -- | Construct a custom error component. - fancy :: ErrorFancy e -> EF e fancy = EF . E.singleton ---------------------------------------------------------------------------- -- Helpers --- | Construct appropriate 'ErrorItem' representation for given token --- stream. Empty string produces 'EndOfInput'. - -canonicalizeTokens :: [t] -> ErrorItem t -canonicalizeTokens ts = - case NE.nonEmpty ts of +-- | Construct the appropriate 'ErrorItem' representation for the given +-- token stream. The empty string produces 'EndOfInput'. +canonicalizeTokens :: + (Stream s) => + Proxy s -> + Tokens s -> + ErrorItem (Token s) +canonicalizeTokens pxy ts = + case NE.nonEmpty (chunkToTokens pxy ts) of Nothing -> EndOfInput Just xs -> Tokens xs -- | Lift an unexpected item into 'ET'. - -unexp :: ErrorItem t -> ET t +unexp :: ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty -- | Lift an expected item into 'ET'. - -expe :: ErrorItem t -> ET t +expe :: ErrorItem (Token s) -> ET s expe p = ET Nothing (E.singleton p) -- | Make a singleton non-empty list from a value. - nes :: a -> NonEmpty a nes x = x :| [] diff --git a/Text/Megaparsec/Expr.hs b/Text/Megaparsec/Expr.hs deleted file mode 100644 --- a/Text/Megaparsec/Expr.hs +++ /dev/null @@ -1,156 +0,0 @@ --- | --- Module : Text.Megaparsec.Expr --- Copyright : © 2015–2018 Megaparsec contributors --- © 2007 Paolo Martini --- © 1999–2001 Daan Leijen --- License : FreeBSD --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : non-portable --- --- A helper module to parse expressions. It can build a parser given a table --- of operators. - -module Text.Megaparsec.Expr - ( Operator (..) - , makeExprParser ) -where - -import Text.Megaparsec - --- | This data type specifies operators that work on values of type @a@. An --- operator is either binary infix or unary prefix or postfix. A binary --- operator has also an associated associativity. - -data Operator m a - = InfixN (m (a -> a -> a)) -- ^ Non-associative infix - | InfixL (m (a -> a -> a)) -- ^ Left-associative infix - | InfixR (m (a -> a -> a)) -- ^ Right-associative infix - | Prefix (m (a -> a)) -- ^ Prefix - | Postfix (m (a -> a)) -- ^ Postfix - --- | @'makeExprParser' term table@ builds an expression parser for terms --- @term@ with operators from @table@, taking the associativity and --- precedence specified in the @table@ into account. --- --- @table@ is a list of @[Operator m a]@ lists. The list is ordered in --- descending precedence. All operators in one list have the same precedence --- (but may have different associativity). --- --- Prefix and postfix operators of the same precedence associate to the left --- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). --- --- Unary operators of the same precedence can only occur once (i.e. @--2@ is --- not allowed if @-@ is prefix negate). If you need to parse several prefix --- or postfix operators in a row, (like C pointers—@**i@) you can use this --- approach: --- --- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp --- --- This is not done by default because in some cases allowing repeating --- prefix or postfix operators is not desirable. --- --- If you want to have an operator that is a prefix of another operator in --- the table, use the following (or similar) wrapper instead of plain --- 'Text.Megaparsec.Char.Lexer.symbol': --- --- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) --- --- 'makeExprParser' takes care of all the complexity involved in building an --- expression parser. Here is an example of an expression parser that --- handles prefix signs, postfix increment and basic arithmetic: --- --- > expr = makeExprParser term table "expression" --- > --- > term = parens expr <|> integer "term" --- > --- > table = [ [ prefix "-" negate --- > , prefix "+" id ] --- > , [ postfix "++" (+1) ] --- > , [ binary "*" (*) --- > , binary "/" div ] --- > , [ binary "+" (+) --- > , binary "-" (-) ] ] --- > --- > binary name f = InfixL (f <$ symbol name) --- > prefix name f = Prefix (f <$ symbol name) --- > postfix name f = Postfix (f <$ symbol name) - -makeExprParser :: MonadParsec e s m - => m a -- ^ Term parser - -> [[Operator m a]] -- ^ Operator table, see 'Operator' - -> m a -- ^ Resulting expression parser -makeExprParser = foldl addPrecLevel -{-# INLINEABLE makeExprParser #-} - --- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@ --- to parser @p@. - -addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a -addPrecLevel term ops = - term' >>= \x -> choice [ras' x, las' x, nas' x, return x] "operator" - where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops - term' = pTerm (choice prefix) term (choice postfix) - ras' = pInfixR (choice ras) term' - las' = pInfixL (choice las) term' - nas' = pInfixN (choice nas) term' - --- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional --- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are --- allowed to fail, in this case 'id' is used. - -pTerm :: MonadParsec e s m => m (a -> a) -> m a -> m (a -> a) -> m a -pTerm prefix term postfix = do - pre <- option id (hidden prefix) - x <- term - post <- option id (hidden postfix) - return . post . pre $ x - --- | @pInfixN op p x@ parses non-associative infix operator @op@, then term --- with parser @p@, then returns result of the operator application on @x@ --- and the term. - -pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixN op p x = do - f <- op - y <- p - return $ f x y - --- | @pInfixL op p x@ parses left-associative infix operator @op@, then term --- with parser @p@, then returns result of the operator application on @x@ --- and the term. - -pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixL op p x = do - f <- op - y <- p - let r = f x y - pInfixL op p r <|> return r - --- | @pInfixR op p x@ parses right-associative infix operator @op@, then --- term with parser @p@, then returns result of the operator application on --- @x@ and the term. - -pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a -pInfixR op p x = do - f <- op - y <- p >>= \r -> pInfixR op p r <|> return r - return $ f x y - -type Batch m a = - ( [m (a -> a -> a)] - , [m (a -> a -> a)] - , [m (a -> a -> a)] - , [m (a -> a)] - , [m (a -> a)] ) - --- | A helper to separate various operators (binary, unary, and according to --- associativity) and return them in a tuple. - -splitOp :: Operator m a -> Batch m a -> Batch m a -splitOp (InfixR op) (r, l, n, pre, post) = (op:r, l, n, pre, post) -splitOp (InfixL op) (r, l, n, pre, post) = (r, op:l, n, pre, post) -splitOp (InfixN op) (r, l, n, pre, post) = (r, l, op:n, pre, post) -splitOp (Prefix op) (r, l, n, pre, post) = (r, l, n, op:pre, post) -splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post) diff --git a/Text/Megaparsec/Internal.hs b/Text/Megaparsec/Internal.hs --- a/Text/Megaparsec/Internal.hs +++ b/Text/Megaparsec/Internal.hs @@ -1,6 +1,19 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Internal --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -13,66 +26,53 @@ -- rely on these unless you really know what you're doing. -- -- @since 6.5.0 - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0) -{-# OPTIONS -Wno-noncanonical-monoid-instances #-} -#endif - module Text.Megaparsec.Internal ( -- * Data types - Hints (..) - , Reply (..) - , Consumption (..) - , Result (..) - , ParsecT (..) + Hints (..), + Reply (..), + Consumption (..), + Result (..), + ParsecT (..), + -- * Helper functions - , toHints - , withHints - , accHints - , refreshLastHint - , runParsecT ) + toHints, + withHints, + accHints, + refreshHints, + runParsecT, + withParsecT, + ) where import Control.Applicative import Control.Monad +import qualified Control.Monad.Combinators import Control.Monad.Cont.Class import Control.Monad.Error.Class +import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader.Class -import Control.Monad.State.Class hiding (state) +import Control.Monad.State.Class import Control.Monad.Trans +import Control.Monad.Writer.Class import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Proxy -import Data.Semigroup hiding (option) +import Data.Semigroup import Data.Set (Set) +import qualified Data.Set as E import Data.String (IsString (..)) import Text.Megaparsec.Class import Text.Megaparsec.Error -import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Control.Monad.Fail as Fail -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E ---------------------------------------------------------------------------- -- Data types -- | 'Hints' represent a collection of 'ErrorItem's to be included into --- 'ParserError' (when it's a 'TrivialError') as “expected” message items +-- 'ParseError' (when it's a 'TrivialError') as “expected” message items -- when a parser fails without consuming input right after successful parser -- that produced the hints. -- @@ -83,82 +83,83 @@ -- unexpected 'a' -- expecting end of input -- --- We're getting better error messages with help of hints: +-- We're getting better error messages with the help of hints: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input +newtype Hints t = Hints (Set (ErrorItem t)) -newtype Hints t = Hints [Set (ErrorItem t)] - deriving (Semigroup, Monoid) +instance (Ord t) => Semigroup (Hints t) where + Hints xs <> Hints ys = Hints $ xs <> ys +instance (Ord t) => Monoid (Hints t) where + mempty = Hints mempty + -- | All information available after parsing. This includes consumption of --- input, success (with returned value) or failure (with parse error), and --- parser state at the end of parsing. +-- input, success (with the returned value) or failure (with the parse +-- error), and parser state at the end of parsing. 'Reply' can also be used +-- to resume parsing. -- -- See also: 'Consumption', 'Result'. - -data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) +data Reply e s a = Reply (State s e) Consumption (Result s e a) + deriving (Functor) --- | This data structure represents an aspect of result of parser's work. +-- | Whether the input has been consumed or not. -- -- See also: 'Result', 'Reply'. - data Consumption - = Consumed -- ^ Some part of input stream was consumed - | Virgin -- ^ No input was consumed + = -- | Some part of input stream was consumed + Consumed + | -- | No input was consumed + NotConsumed --- | This data structure represents an aspect of result of parser's work. +-- | Whether the parser has failed or not. On success we include the +-- resulting value, on failure we include a 'ParseError'. -- -- See also: 'Consumption', 'Reply'. - -data Result t e a - = OK a -- ^ Parser succeeded - | Error (ParseError t e) -- ^ Parser failed +data Result s e a + = -- | Parser succeeded (includes hints) + OK (Hints (Token s)) a + | -- | Parser failed + Error (ParseError s e) + deriving (Functor) -- | @'ParsecT' e s m a@ is a parser with custom data component of error -- @e@, stream type @s@, underlying monad @m@ and return type @a@. - newtype ParsecT e s m a = ParsecT - { unParser - :: forall b. State s - -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK - -> (ParseError (Token s) e -> State s -> m b) -- consumed-error - -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK - -> (ParseError (Token s) e -> State s -> m b) -- empty-error - -> m b } + { unParser :: + forall b. + State s e -> + (a -> State s e -> Hints (Token s) -> m b) -> -- consumed-OK + (ParseError s e -> State s e -> m b) -> -- consumed-error + (a -> State s e -> Hints (Token s) -> m b) -> -- empty-OK + (ParseError s e -> State s e -> m b) -> -- empty-error + m b + } -- | @since 5.3.0 - instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} -#if MIN_VERSION_base(4,8,0) sconcat = fmap sconcat . sequence -#else - sconcat = fmap (sconcat . NE.fromList) . sequence . NE.toList -#endif {-# INLINE sconcat #-} -- | @since 5.3.0 - instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where mempty = pure mempty {-# INLINE mempty #-} -#if MIN_VERSION_base(4,11,0) mappend = (<>) -#else - mappend = liftA2 mappend -#endif {-# INLINE mappend #-} mconcat = fmap mconcat . sequence {-# INLINE mconcat #-} -- | @since 6.3.0 - -instance (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) - => IsString (ParsecT e s m a) where +instance + (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) => + IsString (ParsecT e s m a) + where fromString s = tokens (==) (fromString s) instance Functor (ParsecT e s m) where @@ -170,332 +171,425 @@ {-# INLINE pMap #-} -- | 'pure' returns a parser that __succeeds__ without consuming input. - -instance Stream s => Applicative (ParsecT e s m) where - pure = pPure - (<*>) = pAp +instance (Stream s) => Applicative (ParsecT e s m) where + pure = pPure + (<*>) = pAp p1 *> p2 = p1 `pBind` const p2 - p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } + {-# INLINE (*>) #-} + p1 <* p2 = do x1 <- p1; void p2; return x1 + {-# INLINE (<*) #-} -pPure :: a -> ParsecT e s m a +pPure :: (Stream s) => a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} -pAp :: Stream s - => ParsecT e s m (a -> b) - -> ParsecT e s m a - -> ParsecT e s m b +pAp :: + (Stream s) => + ParsecT e s m (a -> b) -> + ParsecT e s m a -> + ParsecT e s m b pAp m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (cok . x)) (withHints hs cerr) - meok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (eok . x)) (withHints hs eerr) - in unParser m s mcok cerr meok eerr + let mcok x s' hs = + unParser + k + s' + (cok . x) + cerr + (accHints hs (cok . x)) + (withHints hs cerr) + meok x s' hs = + unParser + k + s' + (cok . x) + cerr + (accHints hs (eok . x)) + (withHints hs eerr) + in unParser m s mcok cerr meok eerr {-# INLINE pAp #-} -- | 'empty' is a parser that __fails__ without consuming input. - instance (Ord e, Stream s) => Alternative (ParsecT e s m) where - empty = mzero - (<|>) = mplus + empty = mzero + (<|>) = mplus + many = Control.Monad.Combinators.many + some = Control.Monad.Combinators.some -- | 'return' returns a parser that __succeeds__ without consuming input. - -instance Stream s => Monad (ParsecT e s m) where +instance (Stream s) => Monad (ParsecT e s m) where return = pure - (>>=) = pBind - fail = Fail.fail + (>>=) = pBind -pBind :: Stream s - => ParsecT e s m a - -> (a -> ParsecT e s m b) - -> ParsecT e s m b +pBind :: + (Stream s) => + ParsecT e s m a -> + (a -> ParsecT e s m b) -> + ParsecT e s m b pBind m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser (k x) s' cok cerr - (accHints hs cok) (withHints hs cerr) - meok x s' hs = unParser (k x) s' cok cerr - (accHints hs eok) (withHints hs eerr) - in unParser m s mcok cerr meok eerr + let mcok x s' hs = + unParser + (k x) + s' + cok + cerr + (accHints hs cok) + (withHints hs cerr) + meok x s' hs = + unParser + (k x) + s' + cok + cerr + (accHints hs eok) + (withHints hs eerr) + in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} -instance Stream s => Fail.MonadFail (ParsecT e s m) where +instance (Stream s) => Fail.MonadFail (ParsecT e s m) where fail = pFail pFail :: String -> ParsecT e s m a -pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> +pFail msg = ParsecT $ \s@(State _ o _ _) _ _ _ eerr -> let d = E.singleton (ErrorFail msg) - in eerr (FancyError pos d) s + in eerr (FancyError o d) s {-# INLINE pFail #-} instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where liftIO = lift . liftIO instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where - ask = lift ask - local f p = mkPT $ \s -> local f (runParsecT p s) + ask = lift ask + local f = hoistP (local f) instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put +hoistP :: + (Monad m) => + (m (Reply e s a) -> m (Reply e s b)) -> + ParsecT e s m a -> + ParsecT e s m b +hoistP h p = mkParsecT (h . runParsecT p) + +-- | @since 9.5.0 +instance (Stream s, MonadWriter w m) => MonadWriter w (ParsecT e s m) where + tell w = lift (tell w) + listen = hoistP (fmap (\(repl, w) -> fmap (,w) repl) . listen) + pass = hoistP $ \m -> pass $ do + Reply st consumption r <- m + let (r', ww') = case r of + OK hs (x, ww) -> (OK hs x, ww) + Error e -> (Error e, id) + return (Reply st consumption r', ww') + instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where - callCC f = mkPT $ \s -> + callCC f = mkParsecT $ \s -> callCC $ \c -> - runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s - where pack s a = Reply s Virgin (OK a) + runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s + where + pack s a = Reply s NotConsumed (OK mempty a) instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError - p `catchError` h = mkPT $ \s -> + p `catchError` h = mkParsecT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s -mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a -mkPT k = ParsecT $ \s cok cerr eok eerr -> do +mkParsecT :: + (Monad m) => + (State s e -> m (Reply e s a)) -> + ParsecT e s m a +mkParsecT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of - OK x -> cok x s' mempty + OK hs x -> cok x s' hs Error e -> cerr e s' - Virgin -> + NotConsumed -> case result of - OK x -> eok x s' mempty + OK hs x -> eok x s' hs Error e -> eerr e s' +{-# INLINE mkParsecT #-} --- | 'mzero' is a parser that __fails__ without consuming input. +pmkParsec :: + (State s e -> Reply e s a) -> + ParsecT e s m a +pmkParsec k = ParsecT $ \s cok cerr eok eerr -> + let (Reply s' consumption result) = k s + in case consumption of + Consumed -> + case result of + OK hs x -> cok x s' hs + Error e -> cerr e s' + NotConsumed -> + case result of + OK hs x -> eok x s' hs + Error e -> eerr e s' +{-# INLINE pmkParsec #-} +-- | 'mzero' is a parser that __fails__ without consuming input. +-- +-- __Note__: strictly speaking, this instance is unlawful. The right +-- identity law does not hold, e.g. in general this is not true: +-- +-- > v >> mzero = mzero +-- +-- However the following holds: +-- +-- > try v >> mzero = mzero instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus pZero :: ParsecT e s m a -pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (TrivialError pos Nothing E.empty) s +pZero = ParsecT $ \s@(State _ o _ _) _ _ _ eerr -> + eerr (TrivialError o Nothing E.empty) s {-# INLINE pZero #-} -pPlus :: (Ord e, Stream s) - => ParsecT e s m a - -> ParsecT e s m a - -> ParsecT e s m a +pPlus :: + (Ord e, Stream s) => + ParsecT e s m a -> + ParsecT e s m a -> + ParsecT e s m a pPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err ms = let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') - neok x s' hs = eok x s' (toHints (statePos s') err <> hs) - neerr err' s' = eerr (err' <> err) (longestMatch ms s') - in unParser n s cok ncerr neok neerr - in unParser m s cok cerr eok meerr + neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs) + neerr err' s' = + let combinedErr = combineErrors (stateOffset s) err err' + in eerr combinedErr (longestMatch ms s') + in unParser n s cok ncerr neok neerr + in unParser m s cok cerr eok meerr + where + combineErrors altOffset e1 e2 = case (e1, e2) of + (TrivialError o1 u1 p1, TrivialError o2 u2 p2) -> + -- When merging alternative errors, if one is ahead due to try, we + -- bring both to the alternative position and union their expected + -- tokens. + if o1 > altOffset || o2 > altOffset + then + -- At least one error is ahead, normalize to alt position. Only + -- include expected tokens from errors at the alt position. + let p1' = if o1 == altOffset then p1 else E.empty + p2' = if o2 == altOffset then p2 else E.empty + -- Use the unexpected from the error at alt position, or the + -- furthest. + unexp = case (o1 `compare` altOffset, o2 `compare` altOffset) of + (EQ, _) -> u1 + (_, EQ) -> u2 + _ -> if o1 >= o2 then u1 else u2 + in TrivialError altOffset unexp (E.union p1' p2') + else e2 <> e1 + _ -> e2 <> e1 {-# INLINE pPlus #-} --- | @since 6.0.0 - -instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where - mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do - let - a = case result of - OK a' -> a' - Error _ -> error "mfix ParsecT" - runParsecT (f a) s - -- | From two states, return the one with the greater number of processed -- tokens. If the numbers of processed tokens are equal, prefer the second -- state. - -longestMatch :: State s -> State s -> State s -longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) = - case tp1 `compare` tp2 of +longestMatch :: State s e -> State s e -> State s e +longestMatch s1@(State _ o1 _ _) s2@(State _ o2 _ _) = + case o1 `compare` o2 of LT -> s2 EQ -> s2 GT -> s1 {-# INLINE longestMatch #-} -instance MonadTrans (ParsecT e s) where +-- | @since 6.0.0 +instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where + mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do + let a = case result of + OK _ a' -> a' + Error _ -> error "mfix ParsecT" + runParsecT (f a) s + +instance (Stream s) => MonadTrans (ParsecT e s) where lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where - failure = pFailure - fancyFailure = pFancyFailure - label = pLabel - try = pTry - lookAhead = pLookAhead - notFollowedBy = pNotFollowedBy - withRecovery = pWithRecovery - observing = pObserving - eof = pEof - token = pToken - tokens = pTokens - takeWhileP = pTakeWhileP - takeWhile1P = pTakeWhile1P - takeP = pTakeP - getParserState = pGetParserState + parseError = pParseError + label = pLabel + try = pTry + lookAhead = pLookAhead + notFollowedBy = pNotFollowedBy + withRecovery = pWithRecovery + observing = pObserving + eof = pEof + token = pToken + tokens = pTokens + takeWhileP = pTakeWhileP + takeWhile1P = pTakeWhile1P + takeP = pTakeP + getParserState = pGetParserState updateParserState = pUpdateParserState - -pFailure - :: Maybe (ErrorItem (Token s)) - -> Set (ErrorItem (Token s)) - -> ParsecT e s m a -pFailure us ps = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (TrivialError pos us ps) s -{-# INLINE pFailure #-} + mkParsec = pmkParsec -pFancyFailure - :: Set (ErrorFancy e) - -> ParsecT e s m a -pFancyFailure xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (FancyError pos xs) s -{-# INLINE pFancyFailure #-} +pParseError :: + ParseError s e -> + ParsecT e s m a +pParseError e = ParsecT $ \s _ _ _ eerr -> eerr e s +{-# INLINE pParseError #-} pLabel :: String -> ParsecT e s m a -> ParsecT e s m a pLabel l p = ParsecT $ \s cok cerr eok eerr -> let el = Label <$> NE.nonEmpty l - cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l - cok' x s' hs = cok x s' (refreshLastHint hs cl) - eok' x s' hs = eok x s' (refreshLastHint hs el) - eerr' err = eerr $ + cok' x s' hs = + case el of + Nothing -> cok x s' (refreshHints hs Nothing) + Just _ -> cok x s' hs + eok' x s' hs = eok x s' (refreshHints hs el) + eerr' err = eerr $ case err of (TrivialError pos us _) -> TrivialError pos us (maybe E.empty E.singleton el) _ -> err - in unParser p s cok' cerr eok' eerr' + in unParser p s cok' cerr eok' eerr' {-# INLINE pLabel #-} pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr -> let eerr' err _ = eerr err s - in unParser p s cok eerr' eok eerr' + in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-} -pLookAhead :: ParsecT e s m a -> ParsecT e s m a +pLookAhead :: (Stream s) => ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr -> let eok' a _ _ = eok a s mempty - in unParser p s eok' cerr eok' eerr + in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} -pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () -pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> +pNotFollowedBy :: (Stream s) => ParsecT e s m a -> ParsecT e s m () +pNotFollowedBy p = ParsecT $ \s@(State input o _ _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input) - unexpect u = TrivialError pos (pure u) E.empty - cok' _ _ _ = eerr (unexpect what) s - cerr' _ _ = eok () s mempty - eok' _ _ _ = eerr (unexpect what) s - eerr' _ _ = eok () s mempty - in unParser p s cok' cerr' eok' eerr' + unexpected u = TrivialError o (pure u) E.empty + cok' _ _ _ = eerr (unexpected what) s + cerr' _ _ = eok () s mempty + eok' _ _ _ = eerr (unexpected what) s + eerr' _ _ = eok () s mempty + in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-} -pWithRecovery - :: (ParseError (Token s) e -> ParsecT e s m a) - -> ParsecT e s m a - -> ParsecT e s m a +pWithRecovery :: + (Stream s) => + (ParseError s e -> ParsecT e s m a) -> + ParsecT e s m a -> + ParsecT e s m a pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> let mcerr err ms = let rcok x s' _ = cok x s' mempty - rcerr _ _ = cerr err ms - reok x s' _ = eok x s' (toHints (statePos s') err) - reerr _ _ = cerr err ms - in unParser (r err) ms rcok rcerr reok reerr + rcerr _ _ = cerr err ms + reok x s' _ = eok x s' (toHints (stateOffset s') err) + reerr _ _ = cerr err ms + in unParser (r err) ms rcok rcerr reok reerr meerr err ms = - let rcok x s' _ = cok x s' (toHints (statePos s') err) - rcerr _ _ = eerr err ms - reok x s' _ = eok x s' (toHints (statePos s') err) - reerr _ _ = eerr err ms - in unParser (r err) ms rcok rcerr reok reerr - in unParser p s cok mcerr eok meerr + let rcok x s' _ = cok x s' (toHints (stateOffset s') err) + rcerr _ _ = eerr err ms + reok x s' _ = eok x s' (toHints (stateOffset s') err) + reerr _ _ = eerr err ms + in unParser (r err) ms rcok rcerr reok reerr + in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} -pObserving - :: ParsecT e s m a - -> ParsecT e s m (Either (ParseError (Token s) e) a) +pObserving :: + (Stream s) => + ParsecT e s m a -> + ParsecT e s m (Either (ParseError s e) a) pObserving p = ParsecT $ \s cok _ eok _ -> let cerr' err s' = cok (Left err) s' mempty - eerr' err s' = eok (Left err) s' (toHints (statePos s') err) - in unParser p s (cok . Right) cerr' (eok . Right) eerr' + eerr' err s' = eok (Left err) s' (toHints (stateOffset s') err) + in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} -pEof :: forall e s m. Stream s => ParsecT e s m () -pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> +pEof :: forall e s m. (Stream s) => ParsecT e s m () +pEof = ParsecT $ \s@(State input o pst de) _ _ eok eerr -> case take1_ input of - Nothing -> eok () s mempty - Just (x,_) -> - let !apos = positionAt1 (Proxy :: Proxy s) pos x - us = (pure . Tokens . nes) x - ps = E.singleton EndOfInput - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) + Nothing -> eok () s mempty + Just (x, _) -> + let us = (pure . Tokens . nes) x + ps = E.singleton EndOfInput + in eerr + (TrivialError o us ps) + (State input o pst de) {-# INLINE pEof #-} -pToken :: forall e s m a. Stream s - => (Token s -> Either ( Maybe (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) ) a) - -> Maybe (Token s) - -> ParsecT e s m a -pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> +pToken :: + forall e s m a. + (Stream s) => + (Token s -> Maybe a) -> + Set (ErrorItem (Token s)) -> + ParsecT e s m a +pToken test ps = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> case take1_ input of Nothing -> let us = pure EndOfInput - ps = maybe E.empty (E.singleton . Tokens . nes) mtoken - in eerr (TrivialError (pos:|z) us ps) s - Just (c,cs) -> + in eerr (TrivialError o us ps) s + Just (c, cs) -> case test c of - Left (us, ps) -> - let !apos = positionAt1 (Proxy :: Proxy s) pos c - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) - Right x -> - let !npos = advance1 (Proxy :: Proxy s) w pos c - newstate = State cs (npos:|z) (tp + 1) w - in cok x newstate mempty + Nothing -> + let us = (Just . Tokens . nes) c + in eerr + (TrivialError o us ps) + (State input o pst de) + Just x -> + cok x (State cs (o + 1) pst de) mempty {-# INLINE pToken #-} -pTokens :: forall e s m. Stream s - => (Tokens s -> Tokens s -> Bool) - -> Tokens s - -> ParsecT e s m (Tokens s) -pTokens f tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ eok eerr -> +pTokens :: + forall e s m. + (Stream s) => + (Tokens s -> Tokens s -> Bool) -> + Tokens s -> + ParsecT e s m (Tokens s) +pTokens f tts = ParsecT $ \s@(State input o pst de) cok _ eok eerr -> let pxy = Proxy :: Proxy s - unexpect pos' u = + unexpected pos' u = let us = pure u ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts - in TrivialError pos' us ps + in TrivialError pos' us ps len = chunkLength pxy tts - in case takeN_ len input of - Nothing -> - eerr (unexpect (pos:|z) EndOfInput) s - Just (tts', input') -> - if f tts tts' - then let !npos = advanceN pxy w pos tts' - st = State input' (npos:|z) (tp + len) w - in if chunkEmpty pxy tts - then eok tts' st mempty - else cok tts' st mempty - else let !apos = positionAtN pxy pos tts' - ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' - in eerr (unexpect (apos:|z) ps) (State input (apos:|z) tp w) + in case takeN_ len input of + Nothing -> + eerr (unexpected o EndOfInput) s + Just (tts', input') -> + if f tts tts' + then + let st = State input' (o + len) pst de + in if chunkEmpty pxy tts + then eok tts' st mempty + else cok tts' st mempty + else + let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' + in eerr (unexpected o ps) (State input o pst de) {-# INLINE pTokens #-} -pTakeWhileP :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) -pTakeWhileP ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ eok _ -> +pTakeWhileP :: + forall e s m. + (Stream s) => + Maybe String -> + (Token s -> Bool) -> + ParsecT e s m (Tokens s) +pTakeWhileP ml f = ParsecT $ \(State input o pst de) cok _ eok _ -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input - !npos = advanceN pxy w pos ts len = chunkLength pxy ts hs = case ml >>= NE.nonEmpty of Nothing -> mempty - Just l -> (Hints . pure . E.singleton . Label) l - in if chunkEmpty pxy ts - then eok ts (State input' (npos:|z) (tp + len) w) hs - else cok ts (State input' (npos:|z) (tp + len) w) hs + Just l -> (Hints . E.singleton . Label) l + in if chunkEmpty pxy ts + then eok ts (State input' (o + len) pst de) hs + else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhileP #-} -pTakeWhile1P :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) -pTakeWhile1P ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ _ eerr -> +pTakeWhile1P :: + forall e s m. + (Stream s) => + Maybe String -> + (Token s -> Bool) -> + ParsecT e s m (Tokens s) +pTakeWhile1P ml f = ParsecT $ \(State input o pst de) cok _ _ eerr -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input len = chunkLength pxy ts @@ -503,46 +597,49 @@ hs = case el of Nothing -> mempty - Just l -> (Hints . pure . E.singleton) l - in if chunkEmpty pxy ts - then let !apos = positionAtN pxy pos ts - us = pure $ - case take1_ input of - Nothing -> EndOfInput - Just (t,_) -> Tokens (nes t) - ps = maybe E.empty E.singleton el - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) - else let !npos = advanceN pxy w pos ts - in cok ts (State input' (npos:|z) (tp + len) w) hs + Just l -> (Hints . E.singleton) l + in if chunkEmpty pxy ts + then + let us = pure $ + case take1_ input of + Nothing -> EndOfInput + Just (t, _) -> Tokens (nes t) + ps = maybe E.empty E.singleton el + in eerr + (TrivialError o us ps) + (State input o pst de) + else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhile1P #-} -pTakeP :: forall e s m. Stream s - => Maybe String - -> Int - -> ParsecT e s m (Tokens s) -pTakeP ml n = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> - let pxy = Proxy :: Proxy s +pTakeP :: + forall e s m. + (Stream s) => + Maybe String -> + Int -> + ParsecT e s m (Tokens s) +pTakeP ml n' = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> + let n = max 0 n' + pxy = Proxy :: Proxy s el = Label <$> (ml >>= NE.nonEmpty) ps = maybe E.empty E.singleton el - in case takeN_ n input of - Nothing -> - eerr (TrivialError (pos:|z) (pure EndOfInput) ps) s - Just (ts, input') -> - let len = chunkLength pxy ts - !apos = positionAtN pxy pos ts - !npos = advanceN pxy w pos ts - in if len /= n - then eerr (TrivialError (npos:|z) (pure EndOfInput) ps) - (State input (apos:|z) tp w) - else cok ts (State input' (npos:|z) (tp + len) w) mempty + in case takeN_ n input of + Nothing -> + eerr (TrivialError o (pure EndOfInput) ps) s + Just (ts, input') -> + let len = chunkLength pxy ts + in if len /= n + then + eerr + (TrivialError (o + len) (pure EndOfInput) ps) + (State input o pst de) + else cok ts (State input' (o + len) pst de) mempty {-# INLINE pTakeP #-} -pGetParserState :: ParsecT e s m (State s) +pGetParserState :: (Stream s) => ParsecT e s m (State s e) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s -> State s) -> ParsecT e s m () +pUpdateParserState :: (Stream s) => (State s e -> State s e) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} @@ -553,70 +650,118 @@ ---------------------------------------------------------------------------- -- Helper functions --- | Convert 'ParseError' record into 'Hints'. - -toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t +-- | Convert a 'ParseError' record into 'Hints'. +toHints :: + (Stream s) => + -- | Current offset in input stream + Int -> + -- | Parse error to convert + ParseError s e -> + Hints (Token s) toHints streamPos = \case - TrivialError errPos _ ps -> + TrivialError errOffset _ ps -> -- NOTE This is important to check here that the error indeed has -- happened at the same position as current position of stream because -- there might have been backtracking with 'try' and in that case we -- must not convert such a parse error to hints. - if streamPos == errPos - then Hints (if E.null ps then [] else [ps]) + if streamPos == errOffset + then Hints (if E.null ps then E.empty else ps) else mempty FancyError _ _ -> mempty {-# INLINE toHints #-} --- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. +-- | @'withHints' hs c@ makes “error” continuation @c@ use given hints @hs@. -- --- Note that if resulting continuation gets 'ParseError' that has custom +-- __Note__ that if resulting continuation gets 'ParseError' that has custom -- data in it, hints are ignored. - -withHints :: Ord (Token s) - => Hints (Token s) -- ^ Hints to use - -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence - -> ParseError (Token s) e -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> m b +withHints :: + (Stream s) => + -- | Hints to use + Hints (Token s) -> + -- | Continuation to influence + (ParseError s e -> State s e -> m b) -> + -- | First argument of resulting continuation + ParseError s e -> + -- | Second argument of resulting continuation + State s e -> + m b withHints (Hints ps') c e = case e of - TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps'))) + TrivialError pos us ps -> c (TrivialError pos us (E.union ps ps')) _ -> c e {-# INLINE withHints #-} --- | @accHints hs c@ results in “OK” continuation that will add given hints --- @hs@ to third argument of original continuation @c@. - -accHints - :: Hints t -- ^ 'Hints' to add - -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter - -> a -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> Hints t -- ^ Third argument of resulting continuation - -> m b +-- | @'accHints' hs c@ results in “OK” continuation that will add given +-- hints @hs@ to third argument of original continuation @c@. +accHints :: + (Stream s) => + -- | 'Hints' to add + Hints (Token s) -> + -- | An “OK” continuation to alter + (a -> State s e -> Hints (Token s) -> m b) -> + -- | Altered “OK” continuation + (a -> State s e -> Hints (Token s) -> m b) accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} --- | Replace the most recent group of hints (if any) with the given --- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label' --- primitive. - -refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t -refreshLastHint (Hints []) _ = Hints [] -refreshLastHint (Hints (_:xs)) Nothing = Hints xs -refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) -{-# INLINE refreshLastHint #-} +-- | Replace the hints with the given 'ErrorItem' (or delete it if 'Nothing' +-- is given). This is used in the 'label' primitive. +refreshHints :: Hints t -> Maybe (ErrorItem t) -> Hints t +refreshHints (Hints _) Nothing = Hints E.empty +refreshHints (Hints hs) (Just m) = + if E.null hs + then Hints hs + else Hints (E.singleton m) +{-# INLINE refreshHints #-} -- | Low-level unpacking of the 'ParsecT' type. - -runParsecT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (Reply e s a) +runParsecT :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Initial state + State s e -> + m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr where - cok a s' _ = return $ Reply s' Consumed (OK a) + cok a s' hs = return $ Reply s' Consumed (OK hs a) cerr err s' = return $ Reply s' Consumed (Error err) - eok a s' _ = return $ Reply s' Virgin (OK a) - eerr err s' = return $ Reply s' Virgin (Error err) + eok a s' hs = return $ Reply s' NotConsumed (OK hs a) + eerr err s' = return $ Reply s' NotConsumed (Error err) + +-- | Transform any custom errors thrown by the parser using the given +-- function. Similar in function and purpose to @withExceptT@. +-- +-- __Note__ that the inner parser will start with an empty collection of +-- “delayed” 'ParseError's. Any delayed 'ParseError's produced in the inner +-- parser will be lifted by applying the provided function and added to the +-- collection of delayed parse errors of the outer parser. +-- +-- @since 7.0.0 +withParsecT :: + forall e e' s m a. + (Ord e') => + (e -> e') -> + -- | Inner parser + ParsecT e s m a -> + -- | Outer parser + ParsecT e' s m a +withParsecT f p = + ParsecT $ \s cok cerr eok eerr -> + let s' = + s + { stateParseErrors = [] + } + adjustState :: State s e -> State s e' + adjustState st = + st + { stateParseErrors = + (mapParseError f <$> stateParseErrors st) + ++ stateParseErrors s + } + cok' x st hs = cok x (adjustState st) hs + cerr' e st = cerr (mapParseError f e) (adjustState st) + eok' x st hs = eok x (adjustState st) hs + eerr' e st = eerr (mapParseError f e) (adjustState st) + in unParser p s' cok' cerr' eok' eerr' +{-# INLINE withParsecT #-} 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 new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Lexer.hs @@ -0,0 +1,124 @@ +{-# 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.Lexer + ( -- * White space + space, + lexeme, + symbol, + symbol', + ) +where + +import qualified Data.CaseInsensitive as CI +import Text.Megaparsec +import Text.Megaparsec.Common + +---------------------------------------------------------------------------- +-- White space + +-- | @'space' sc lineComment blockComment@ produces a parser that can parse +-- white space in general. It's expected that you create such a parser once +-- and pass it to other functions in this module as needed (when you see +-- @spaceConsumer@ in documentation, usually it means that something like +-- 'space' is expected there). +-- +-- @sc@ is used to parse blocks of space characters. You can use +-- 'Text.Megaparsec.Char.space1' from "Text.Megaparsec.Char" for this +-- purpose as well as your own parser (if you don't want to automatically +-- consume newlines, for example). Make sure that the parser does not +-- succeed on the empty input though. In an earlier version of the library +-- 'Text.Megaparsec.Char.spaceChar' was recommended, but now parsers based +-- on 'takeWhile1P' are preferred because of their speed. +-- +-- @lineComment@ is used to parse line comments. You can use +-- @skipLineComment@ if you don't need anything special. +-- +-- @blockComment@ is used to parse block (multi-line) comments. You can use +-- @skipBlockComment@ or @skipBlockCommentNested@ if you don't need anything +-- special. +-- +-- If you don't want to allow a kind of comment, simply pass 'empty' which +-- will fail instantly when parsing of that sort of comment is attempted and +-- 'space' will just move on or finish depending on whether there is more +-- white space for it to consume. +space :: + (MonadParsec e s m) => + -- | A parser for space characters which does not accept empty + -- input (e.g. 'Text.Megaparsec.Char.space1') + m () -> + -- | A parser for a line comment (e.g. 'skipLineComment') + m () -> + -- | A parser for a block comment (e.g. 'skipBlockComment') + m () -> + m () +space sp line block = + skipMany $ + choice + [hidden sp, hidden line, hidden block] +{-# INLINEABLE space #-} + +-- | This is a wrapper for lexemes. The typical usage is to supply the first +-- argument (parser that consumes white space, probably defined via 'space') +-- and use the resulting function to wrap parsers for every lexeme. +-- +-- > lexeme = L.lexeme spaceConsumer +-- > integer = lexeme L.decimal +lexeme :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | How to parse actual lexeme + m a -> + m a +lexeme spc p = p <* spc +{-# INLINEABLE lexeme #-} + +-- | This is a helper to parse symbols, i.e. verbatim strings. You pass the +-- first argument (parser that consumes white space, probably defined via +-- 'space') and then you can use the resulting function to parse strings: +-- +-- > symbol = L.symbol spaceConsumer +-- > +-- > parens = between (symbol "(") (symbol ")") +-- > braces = between (symbol "{") (symbol "}") +-- > angles = between (symbol "<") (symbol ">") +-- > brackets = between (symbol "[") (symbol "]") +-- > semicolon = symbol ";" +-- > comma = symbol "," +-- > colon = symbol ":" +-- > dot = symbol "." +symbol :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse + Tokens s -> + m (Tokens s) +symbol spc = lexeme spc . string +{-# INLINEABLE symbol #-} + +-- | A case-insensitive version of 'symbol'. This may be helpful if you're +-- working with case-insensitive languages. +symbol' :: + (MonadParsec e s m, CI.FoldCase (Tokens s)) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse (case-insensitive) + Tokens s -> + m (Tokens s) +symbol' spc = lexeme spc . string' +{-# INLINEABLE symbol' #-} 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–2018 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 - -#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–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -8,41 +13,31 @@ -- Portability : portable -- -- Textual source position. The position includes name of file, line number, --- and column number. List of such positions can be used to model a stack of --- include files. +-- and column number. -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Text.Megaparsec.Pos ( -- * Abstract position - Pos - , mkPos - , unPos - , pos1 - , defaultTabWidth - , InvalidPosException (..) + Pos, + mkPos, + unPos, + pos1, + defaultTabWidth, + InvalidPosException (..), + -- * Source position - , SourcePos (..) - , initialPos - , sourcePosPretty ) + SourcePos (..), + initialPos, + sourcePosPretty, + ) where import Control.DeepSeq import Control.Exception import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - ---------------------------------------------------------------------------- -- Abstract position @@ -52,15 +47,13 @@ -- together. -- -- @since 5.0.0 - newtype Pos = Pos Int - deriving (Show, Eq, Ord, Data, Typeable, NFData) + deriving (Show, Eq, Ord, Data, Generic, NFData) -- | Construction of 'Pos' from 'Int'. The function throws -- 'InvalidPosException' when given a non-positive argument. -- -- @since 6.0.0 - mkPos :: Int -> Pos mkPos a = if a <= 0 @@ -71,7 +64,6 @@ -- | Extract 'Int' from 'Pos'. -- -- @since 6.0.0 - unPos :: Pos -> Int unPos (Pos w) = w {-# INLINE unPos #-} @@ -79,7 +71,6 @@ -- | Position with value 1. -- -- @since 6.0.0 - pos1 :: Pos pos1 = mkPos 1 @@ -87,8 +78,11 @@ -- you want to refer to the default tab width because actual value /may/ -- change in future. -- +-- Currently: +-- +-- > defaultTabWidth = mkPos 8 +-- -- @since 5.0.0 - defaultTabWidth :: Pos defaultTabWidth = mkPos 8 @@ -100,22 +94,22 @@ readsPrec d = readParen (d > 10) $ \r1 -> do ("Pos", r2) <- lex r1 - (x, r3) <- readsPrec 11 r2 + (x, r3) <- readsPrec 11 r2 return (mkPos x, r3) -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number. -- -- @since 5.0.0 - -data InvalidPosException = InvalidPosException Int - -- ^ The first value is the minimal allowed value, the second value is the - -- actual value that was passed to 'mkPos'. - deriving (Eq, Show, Data, Typeable, Generic) +newtype InvalidPosException + = -- | Contains the actual value that was passed to 'mkPos' + InvalidPosException Int + deriving (Eq, Show, Data, Generic) instance Exception InvalidPosException -instance NFData InvalidPosException +instance NFData InvalidPosException + ---------------------------------------------------------------------------- -- Source position @@ -123,28 +117,29 @@ -- name of the source file, a line number, and a column number. Source line -- and column positions change intensively during parsing, so we need to -- make them strict to avoid memory leaks. - data SourcePos = SourcePos - { sourceName :: FilePath -- ^ Name of source file - , sourceLine :: !Pos -- ^ Line number - , sourceColumn :: !Pos -- ^ Column number - } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) + { -- | Name of source file + sourceName :: FilePath, + -- | Line number + sourceLine :: !Pos, + -- | Column number + sourceColumn :: !Pos + } + deriving (Show, Read, Eq, Ord, Data, Generic) instance NFData SourcePos -- | Construct initial position (line 1, column 1) given name of source -- file. - initialPos :: FilePath -> SourcePos initialPos n = SourcePos n pos1 pos1 -- | Pretty-print a 'SourcePos'. -- -- @since 5.0.0 - sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c) - | null n = showLC + | null n = showLC | otherwise = n <> ":" <> showLC where showLC = show (unPos l) <> ":" <> show (unPos c) diff --git a/Text/Megaparsec/State.hs b/Text/Megaparsec/State.hs --- a/Text/Megaparsec/State.hs +++ b/Text/Megaparsec/State.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.State --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD @@ -12,34 +19,115 @@ -- Definition of Megaparsec's 'State'. -- -- @since 6.5.0 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - module Text.Megaparsec.State - ( State (..) ) + ( State (..), + initialState, + PosState (..), + initialPosState, + ) where import Control.DeepSeq (NFData) import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Typeable (Typeable) import GHC.Generics +import {-# SOURCE #-} Text.Megaparsec.Error (ParseError) import Text.Megaparsec.Pos --- | This is the Megaparsec's state parametrized over stream type @s@. - -data State s = State - { stateInput :: s - -- ^ The rest of input to process - , statePos :: NonEmpty SourcePos - -- ^ Current position (column + line number) with support for include files - , stateTokensProcessed :: {-# UNPACK #-} !Int - -- ^ Number of processed tokens so far +-- | This is the Megaparsec's state parametrized over stream type @s@ and +-- custom error component type @e@. +data State s e = State + { -- | The rest of input to process + stateInput :: s, + -- | Number of processed tokens so far -- - -- @since 5.2.0 - , stateTabWidth :: Pos - -- ^ Tab width to use - } deriving (Show, Eq, Data, Typeable, Generic) + -- @since 7.0.0 + stateOffset :: {-# UNPACK #-} !Int, + -- | State that is used for line\/column calculation + -- + -- @since 7.0.0 + statePosState :: PosState s, + -- | Collection of “delayed” 'ParseError's in reverse order. This means + -- that the last registered error is the first element of the list. + -- + -- @since 8.0.0 + stateParseErrors :: [ParseError s e] + } + deriving (Generic) -instance NFData s => NFData (State s) +deriving instance + ( Show (ParseError s e), + Show s + ) => + Show (State s e) + +deriving instance + ( Eq (ParseError s e), + Eq s + ) => + Eq (State s e) + +deriving instance + ( Data e, + Data (ParseError s e), + Data s + ) => + Data (State s e) + +instance (NFData s, NFData (ParseError s e)) => NFData (State s e) + +-- | Given the name of the source file and the input construct the initial +-- state for a parser. +-- +-- @since 9.6.0 +initialState :: + -- | Name of the file the input is coming from + FilePath -> + -- | Input + s -> + State s e +initialState name s = + State + { stateInput = s, + stateOffset = 0, + statePosState = initialPosState name s, + stateParseErrors = [] + } + +-- | A special kind of state that is used to calculate line\/column +-- positions on demand. +-- +-- @since 7.0.0 +data PosState s = PosState + { -- | The rest of input to process + pstateInput :: s, + -- | Offset corresponding to beginning of 'pstateInput' + pstateOffset :: !Int, + -- | Source position corresponding to beginning of 'pstateInput' + pstateSourcePos :: !SourcePos, + -- | Tab width to use for column calculation + pstateTabWidth :: Pos, + -- | Prefix to prepend to offending line + pstateLinePrefix :: String + } + deriving (Show, Eq, Data, Generic) + +instance (NFData s) => NFData (PosState s) + +-- | Given the name of source file and the input construct the initial +-- positional state. +-- +-- @since 9.6.0 +initialPosState :: + -- | Name of the file the input is coming from + FilePath -> + -- | Input + s -> + PosState s +initialPosState name s = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos name, + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } diff --git a/Text/Megaparsec/Stream.hs b/Text/Megaparsec/Stream.hs --- a/Text/Megaparsec/Stream.hs +++ b/Text/Megaparsec/Stream.hs @@ -1,6 +1,18 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Stream --- Copyright : © 2015–2018 Megaparsec contributors +-- Copyright : © 2015–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -13,41 +25,52 @@ -- "Text.Megaparsec" re-exports it anyway. -- -- @since 6.0.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Stream - ( Stream (..) ) + ( Stream (..), + ShareInput (..), + NoShareInput (..), + VisualStream (..), + TraversableStream (..), + ) where -import Data.List (foldl') +import Data.Bifunctor (second) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Char (chr) +import Data.Foldable (toList) +import Data.Kind (Type) +import qualified Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) import Data.Proxy -import Data.Semigroup ((<>)) +import qualified Data.Sequence as S +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Word (Word8) import Text.Megaparsec.Pos -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Text.Megaparsec.State +import qualified Text.Megaparsec.Unicode as Unicode -- | Type class for inputs that can be consumed by the library. - +-- +-- Note that the 'Stream' instances for 'Text' and 'ByteString' (strict and +-- lazy) default to "input sharing" (see 'ShareInput', 'NoShareInput'). We plan +-- to move away from input sharing in a future major release; if you want to +-- retain the current behaviour and are concerned with maximum performance you +-- should consider using the 'ShareInput' wrapper explicitly. +-- +-- __Note__: before the version /9.0.0/ the class included the methods from +-- 'VisualStream' and 'TraversableStream'. class (Ord (Token s), Ord (Tokens s)) => Stream s where - -- | Type of token in the stream. - - type Token s :: * + type Token s :: Type -- | Type of “chunk” of the stream. - - type Tokens s :: * + type Tokens s :: Type -- | Lift a single token to chunk of the stream. The default -- implementation is: @@ -56,26 +79,22 @@ -- -- However for some types of stream there may be a more efficient way to -- lift. - - tokenToChunk :: Proxy s -> Token s -> Tokens s + tokenToChunk :: Proxy s -> Token s -> Tokens s tokenToChunk pxy = tokensToChunk pxy . pure -- | The first method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > chunkToTokens pxy (tokensToChunk pxy ts) == ts - tokensToChunk :: Proxy s -> [Token s] -> Tokens s -- | The second method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > tokensToChunk pxy (chunkToTokens pxy chunk) == chunk - chunkToTokens :: Proxy s -> Tokens s -> [Token s] -- | Return length of a chunk of the stream. - chunkLength :: Proxy s -> Tokens s -> Int -- | Check if a chunk of the stream is empty. The default implementation @@ -84,61 +103,11 @@ -- > chunkEmpty pxy ts = chunkLength pxy ts <= 0 -- -- However for many streams there may be a more efficient implementation. - chunkEmpty :: Proxy s -> Tokens s -> Bool chunkEmpty pxy ts = chunkLength pxy ts <= 0 - {-# INLINE chunkEmpty #-} - -- | Set source position __at__ given token. By default, the given - -- 'SourcePos' (second argument) is just returned without looking at the - -- token. This method is important when your stream is a collection of - -- tokens where every token knows where it begins in the original input. - - positionAt1 - :: Proxy s -- ^ 'Proxy' clarifying the type of stream - -> SourcePos -- ^ Current position - -> Token s -- ^ Current token - -> SourcePos -- ^ Position of the token - positionAt1 Proxy = defaultPositionAt - {-# INLINE positionAt1 #-} - - -- | The same as 'positionAt1', but for chunks of the stream. The function - -- should return the position where the entire chunk begins. Again, by - -- default the second argument is returned without modifications and the - -- chunk is not looked at. - - positionAtN - :: Proxy s -- ^ 'Proxy' clarifying the type of stream - -> SourcePos -- ^ Current position - -> Tokens s -- ^ Current chunk - -> SourcePos -- ^ Position of the chunk - positionAtN Proxy = defaultPositionAt - {-# INLINE positionAtN #-} - - -- | Advance position given a single token. The returned position is the - -- position right after the token, or the position where the token ends. - - advance1 - :: Proxy s -- ^ 'Proxy' clarifying the type of stream - -> Pos -- ^ Tab width - -> SourcePos -- ^ Current position - -> Token s -- ^ Current token - -> SourcePos -- ^ Advanced position - - -- | Advance position given a chunk of stream. The returned position is - -- the position right after the chunk, or the position where the chunk - -- ends. - - advanceN - :: Proxy s -- ^ 'Proxy' clarifying the type of stream - -> Pos -- ^ Tab width - -> SourcePos -- ^ Current position - -> Tokens s -- ^ Current token - -> SourcePos -- ^ Advanced position - -- | Extract a single token form the stream. Return 'Nothing' if the -- stream is empty. - take1_ :: s -> Maybe (Token s, s) -- | @'takeN_' n s@ should try to extract a chunk of length @n@, or if the @@ -154,7 +123,6 @@ -- * In other cases, take chunk of length @n@ (or shorter if the -- stream is not long enough) from the input stream and return the -- chunk along with the rest of the stream. - takeN_ :: Int -> s -> Maybe (Tokens s, s) -- | Extract chunk of the stream taking tokens while the supplied @@ -163,124 +131,649 @@ -- For many types of streams, the method allows for significant -- performance improvements, although it is not strictly necessary from -- conceptual point of view. - takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s) -instance Stream String where - type Token String = Char - type Tokens String = String +-- | @since 9.0.0 +instance (Ord a) => Stream [a] where + type Token [a] = a + type Tokens [a] = [a] tokenToChunk Proxy = pure tokensToChunk Proxy = id chunkToTokens Proxy = id chunkLength Proxy = length chunkEmpty Proxy = null - advance1 Proxy = defaultAdvance1 - advanceN Proxy w = foldl' (defaultAdvance1 w) take1_ [] = Nothing - take1_ (t:ts) = Just (t, ts) + take1_ (t : ts) = Just (t, ts) takeN_ n s - | n <= 0 = Just ("", s) - | null s = Nothing + | n <= 0 = Just ([], s) + | null s = Nothing | otherwise = Just (splitAt n s) takeWhile_ = span -instance Stream B.ByteString where - type Token B.ByteString = Word8 - type Tokens B.ByteString = B.ByteString +-- | @since 9.0.0 +instance (Ord a) => Stream (S.Seq a) where + type Token (S.Seq a) = a + type Tokens (S.Seq a) = S.Seq a + tokenToChunk Proxy = pure + tokensToChunk Proxy = S.fromList + chunkToTokens Proxy = toList + chunkLength Proxy = length + chunkEmpty Proxy = null + take1_ S.Empty = Nothing + take1_ (t S.:<| ts) = Just (t, ts) + takeN_ n s + | n <= 0 = Just (S.empty, s) + | null s = Nothing + | otherwise = Just (S.splitAt n s) + takeWhile_ = S.spanl + +-- | This wrapper selects the input-sharing 'Stream' implementation for +-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). By input +-- sharing we mean that our parsers will use slices whenever possible to +-- avoid having to copy parts of the input. See also the documentation of +-- 'T.split'. +-- +-- Note that using slices is in general faster than copying; on the other +-- hand it also has the potential for causing surprising memory leaks: if +-- any slice of the input survives in the output, holding on to the output +-- will force the entire input 'T.Text'/'B.ByteString' to stay in memory! +-- Even when using lazy 'TL.Text'/'BL.ByteString' we will hold on to whole +-- chunks at a time leading to to significantly worse memory residency in +-- some cases. +-- +-- See 'NoShareInput' for a somewhat slower implementation that avoids this +-- memory leak scenario. +-- +-- @since 9.3.0 +newtype ShareInput a = ShareInput {unShareInput :: a} + +instance Stream (ShareInput B.ByteString) where + type Token (ShareInput B.ByteString) = Word8 + type Tokens (ShareInput B.ByteString) = B.ByteString tokenToChunk Proxy = B.singleton tokensToChunk Proxy = B.pack chunkToTokens Proxy = B.unpack chunkLength Proxy = B.length chunkEmpty Proxy = B.null - advance1 Proxy = defaultAdvance1 - advanceN Proxy w = B.foldl' (defaultAdvance1 w) - take1_ = B.uncons - takeN_ n s - | n <= 0 = Just (B.empty, s) - | B.null s = Nothing - | otherwise = Just (B.splitAt n s) - takeWhile_ = B.span + take1_ (ShareInput s) = second ShareInput <$> B.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (B.empty, ShareInput s) + | B.null s = Nothing + | otherwise = Just . second ShareInput $ B.splitAt n s + takeWhile_ p (ShareInput s) = second ShareInput $ B.span p s -instance Stream BL.ByteString where - type Token BL.ByteString = Word8 - type Tokens BL.ByteString = BL.ByteString +instance Stream (ShareInput BL.ByteString) where + type Token (ShareInput BL.ByteString) = Word8 + type Tokens (ShareInput BL.ByteString) = BL.ByteString tokenToChunk Proxy = BL.singleton tokensToChunk Proxy = BL.pack chunkToTokens Proxy = BL.unpack chunkLength Proxy = fromIntegral . BL.length chunkEmpty Proxy = BL.null - advance1 Proxy = defaultAdvance1 - advanceN Proxy w = BL.foldl' (defaultAdvance1 w) - take1_ = BL.uncons - takeN_ n s - | n <= 0 = Just (BL.empty, s) + take1_ (ShareInput s) = second ShareInput <$> BL.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (BL.empty, ShareInput s) | BL.null s = Nothing - | otherwise = Just (BL.splitAt (fromIntegral n) s) - takeWhile_ = BL.span + | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s + takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s -instance Stream T.Text where - type Token T.Text = Char - type Tokens T.Text = T.Text +instance Stream (ShareInput T.Text) where + type Token (ShareInput T.Text) = Char + type Tokens (ShareInput T.Text) = T.Text tokenToChunk Proxy = T.singleton tokensToChunk Proxy = T.pack chunkToTokens Proxy = T.unpack chunkLength Proxy = T.length chunkEmpty Proxy = T.null - advance1 Proxy = defaultAdvance1 - advanceN Proxy w = T.foldl' (defaultAdvance1 w) - take1_ = T.uncons - takeN_ n s - | n <= 0 = Just (T.empty, s) - | T.null s = Nothing - | otherwise = Just (T.splitAt n s) - takeWhile_ = T.span + take1_ (ShareInput s) = second ShareInput <$> T.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (T.empty, ShareInput s) + | T.null s = Nothing + | otherwise = Just . second ShareInput $ T.splitAt n s + takeWhile_ p (ShareInput s) = second ShareInput $ T.span p s -instance Stream TL.Text where - type Token TL.Text = Char - type Tokens TL.Text = TL.Text +instance Stream (ShareInput TL.Text) where + type Token (ShareInput TL.Text) = Char + type Tokens (ShareInput TL.Text) = TL.Text tokenToChunk Proxy = TL.singleton tokensToChunk Proxy = TL.pack chunkToTokens Proxy = TL.unpack chunkLength Proxy = fromIntegral . TL.length chunkEmpty Proxy = TL.null - advance1 Proxy = defaultAdvance1 - advanceN Proxy w = TL.foldl' (defaultAdvance1 w) - take1_ = TL.uncons - takeN_ n s - | n <= 0 = Just (TL.empty, s) + take1_ (ShareInput s) = second ShareInput <$> TL.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (TL.empty, ShareInput s) | TL.null s = Nothing - | otherwise = Just (TL.splitAt (fromIntegral n) s) - takeWhile_ = TL.span + | otherwise = Just . second ShareInput $ TL.splitAt (fromIntegral n) s + takeWhile_ p (ShareInput s) = second ShareInput $ TL.span p s +-- | This wrapper selects the no-input-sharing 'Stream' implementation for +-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). This means +-- that our parsers will create independent copies rather than using slices +-- of the input. See also the documentation of 'T.copy'. +-- +-- More importantly, any parser output will be independent of the input, and +-- holding on to parts of the output will never prevent the input from being +-- garbage collected. +-- +-- For maximum performance you might consider using 'ShareInput' instead, +-- but beware of its pitfalls! +-- +-- @since 9.3.0 +newtype NoShareInput a = NoShareInput {unNoShareInput :: a} + +instance Stream (NoShareInput B.ByteString) where + type Token (NoShareInput B.ByteString) = Word8 + type Tokens (NoShareInput B.ByteString) = B.ByteString + tokenToChunk Proxy = B.singleton + tokensToChunk Proxy = B.pack + chunkToTokens Proxy = B.unpack + chunkLength Proxy = B.length + chunkEmpty Proxy = B.null + take1_ (NoShareInput s) = second NoShareInput <$> B.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (B.empty, NoShareInput s) + | B.null s = Nothing + | otherwise = + let (result, rest) = B.splitAt n s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = B.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = B.span p s + -- Ditto. + unSharedResult = B.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput BL.ByteString) where + type Token (NoShareInput BL.ByteString) = Word8 + type Tokens (NoShareInput BL.ByteString) = BL.ByteString + tokenToChunk Proxy = BL.singleton + tokensToChunk Proxy = BL.pack + chunkToTokens Proxy = BL.unpack + chunkLength Proxy = fromIntegral . BL.length + chunkEmpty Proxy = BL.null + take1_ (NoShareInput s) = second NoShareInput <$> BL.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (BL.empty, NoShareInput s) + | BL.null s = Nothing + | otherwise = + let (result, rest) = BL.splitAt (fromIntegral n) s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = BL.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = BL.span p s + -- Ditto. + unSharedResult = BL.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput T.Text) where + type Token (NoShareInput T.Text) = Char + type Tokens (NoShareInput T.Text) = T.Text + tokenToChunk Proxy = T.singleton + tokensToChunk Proxy = T.pack + chunkToTokens Proxy = T.unpack + chunkLength Proxy = T.length + chunkEmpty Proxy = T.null + take1_ (NoShareInput s) = second NoShareInput <$> T.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (T.empty, NoShareInput s) + | T.null s = Nothing + | otherwise = + let (result, rest) = T.splitAt n s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = T.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = T.span p s + unSharedResult = T.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput TL.Text) where + type Token (NoShareInput TL.Text) = Char + type Tokens (NoShareInput TL.Text) = TL.Text + tokenToChunk Proxy = TL.singleton + tokensToChunk Proxy = TL.pack + chunkToTokens Proxy = TL.unpack + chunkLength Proxy = fromIntegral . TL.length + chunkEmpty Proxy = TL.null + take1_ (NoShareInput s) = second NoShareInput <$> TL.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (TL.empty, NoShareInput s) + | TL.null s = Nothing + | otherwise = + let (result, rest) = TL.splitAt (fromIntegral n) s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = tlCopy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = TL.span p s + unSharedResult = tlCopy result + in (unSharedResult, NoShareInput rest) + +-- | Create an independent copy of a TL.Text, akin to BL.copy. +tlCopy :: TL.Text -> TL.Text +tlCopy = TL.fromStrict . T.copy . TL.toStrict +{-# INLINE tlCopy #-} + +-- Since we are using @{-# LANGUAGE Safe #-}@ we can't use deriving via in +-- these cases. + +instance Stream B.ByteString where + type Token B.ByteString = Token (ShareInput B.ByteString) + type Tokens B.ByteString = Tokens (ShareInput B.ByteString) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput B.ByteString)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput B.ByteString)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput B.ByteString)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput B.ByteString)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput B.ByteString)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream BL.ByteString where + type Token BL.ByteString = Token (ShareInput BL.ByteString) + type Tokens BL.ByteString = Tokens (ShareInput BL.ByteString) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput BL.ByteString)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput BL.ByteString)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream T.Text where + type Token T.Text = Token (ShareInput T.Text) + type Tokens T.Text = Tokens (ShareInput T.Text) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput T.Text)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput T.Text)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput T.Text)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput T.Text)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput T.Text)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream TL.Text where + type Token TL.Text = Token (ShareInput TL.Text) + type Tokens TL.Text = Tokens (ShareInput TL.Text) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput TL.Text)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput TL.Text)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput TL.Text)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput TL.Text)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput TL.Text)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +-- | Type class for inputs that can also be used for debugging. +-- +-- @since 9.0.0 +class (Stream s) => VisualStream s where + -- | Pretty-print non-empty stream of tokens. This function is also used + -- to print single tokens (represented as singleton lists). + -- + -- @since 7.0.0 + showTokens :: Proxy s -> NonEmpty (Token s) -> String + + -- | Return the number of characters that a non-empty stream of tokens + -- spans. The default implementation is sufficient if every token spans + -- exactly 1 character. + -- + -- @since 8.0.0 + tokensLength :: Proxy s -> NonEmpty (Token s) -> Int + tokensLength Proxy = NE.length + +instance VisualStream String where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +instance VisualStream B.ByteString where + showTokens Proxy = stringPretty . fmap (chr . fromIntegral) + +instance VisualStream BL.ByteString where + showTokens Proxy = stringPretty . fmap (chr . fromIntegral) + +instance VisualStream T.Text where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +instance VisualStream TL.Text where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +-- | Type class for inputs that can also be used for error reporting. +-- +-- @since 9.0.0 +class (Stream s) => TraversableStream s where + {-# MINIMAL reachOffset | reachOffsetNoLine #-} + + -- | Given an offset @o@ and initial 'PosState', adjust the state in such + -- a way that it starts at the offset. + -- + -- Return two values (in order): + -- + -- * 'Maybe' 'String' representing the line on which the given offset + -- @o@ is located. It can be omitted (i.e. 'Nothing'); in that case + -- error reporting functions will not show offending lines. If + -- returned, the line should satisfy a number of conditions that are + -- described below. + -- * The updated 'PosState' which can be in turn used to locate + -- another offset @o'@ given that @o' >= o@. + -- + -- The 'String' representing the offending line in input stream should + -- satisfy the following: + -- + -- * It should adequately represent location of token at the offset of + -- interest, that is, character at 'sourceColumn' of the returned + -- 'SourcePos' should correspond to the token at the offset @o@. + -- * It should not include the newline at the end. + -- * It should not be empty, if the line happens to be empty, it + -- should be replaced with the string @\"\\"@. + -- * Tab characters should be replaced by appropriate number of + -- spaces, which is determined by the 'pstateTabWidth' field of + -- 'PosState'. + -- + -- __Note__: type signature of the function was changed in the version + -- /9.0.0/. + -- + -- @since 7.0.0 + reachOffset :: + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | See the description of the function + (Maybe String, PosState s) + reachOffset o pst = + (Nothing, reachOffsetNoLine o pst) + + -- | A version of 'reachOffset' that may be faster because it doesn't need + -- to fetch the line at which the given offset in located. + -- + -- The default implementation is this: + -- + -- > reachOffsetNoLine o pst = + -- > snd (reachOffset o pst) + -- + -- __Note__: type signature of the function was changed in the version + -- /8.0.0/. + -- + -- @since 7.0.0 + reachOffsetNoLine :: + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Reached source position and updated state + PosState s + reachOffsetNoLine o pst = + snd (reachOffset o pst) + +instance TraversableStream String where + -- NOTE Do not eta-reduce these (breaks inlining) + reachOffset o pst = + reachOffset' splitAt Data.List.foldl' id id ('\n', '\t') charInc o pst + reachOffsetNoLine o pst = + reachOffsetNoLine' splitAt Data.List.foldl' ('\n', '\t') charInc o pst + +instance TraversableStream B.ByteString where + -- NOTE Do not eta-reduce these (breaks inlining) + reachOffset o pst = + reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) byteInc o pst + reachOffsetNoLine o pst = + reachOffsetNoLine' B.splitAt B.foldl' (10, 9) byteInc o pst + +instance TraversableStream BL.ByteString where + -- NOTE Do not eta-reduce these (breaks inlining) + reachOffset o pst = + reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) byteInc o pst + reachOffsetNoLine o pst = + reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) byteInc o pst + +instance TraversableStream T.Text where + -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). + reachOffset o pst = + reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') charInc o pst + reachOffsetNoLine o pst = + reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') charInc o pst + +instance TraversableStream TL.Text where + -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). + reachOffset o pst = + reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') charInc o pst + reachOffsetNoLine o pst = + reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') charInc o pst + ---------------------------------------------------------------------------- -- Helpers --- | Default positioning function designed to work with simple streams where --- tokens do not contain info about their position in the stream. Thus it --- just returns the given 'SourcePos' without re-positioning. +-- | An internal helper state type combining a difference 'String' and an +-- unboxed 'SourcePos'. +data St = St {-# UNPACK #-} !SourcePos ShowS -defaultPositionAt :: SourcePos -> a -> SourcePos -defaultPositionAt pos _ = pos -{-# INLINE defaultPositionAt #-} +-- | A helper definition to facilitate defining 'reachOffset' for various +-- stream types. +reachOffset' :: + forall s. + (Stream s) => + -- | How to split input stream at given offset + (Int -> s -> (Tokens s, s)) -> + -- | How to fold over input stream + (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) -> + -- | How to convert chunk of input stream into a 'String' + (Tokens s -> String) -> + -- | How to convert a token into a 'Char' + (Token s -> Char) -> + -- | Newline token and tab token + (Token s, Token s) -> + -- | Update column position for a token + (Token s -> Pos -> Pos) -> + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Line at which 'SourcePos' is located, updated 'PosState' + (Maybe String, PosState s) +reachOffset' + splitAt' + foldl'' + fromToks + fromTok + (newlineTok, tabTok) + columnIncrement + o + PosState {..} = + ( Just $ case expandTab pstateTabWidth + . addPrefix + . f + . fromToks + . fst + $ takeWhile_ (/= newlineTok) post of + "" -> "" + xs -> xs, + PosState + { pstateInput = post, + pstateOffset = max pstateOffset o, + pstateSourcePos = spos, + pstateTabWidth = pstateTabWidth, + pstateLinePrefix = + if sameLine + then -- NOTE We don't use difference lists here because it's + -- desirable for 'PosState' to be an instance of 'Eq' and + -- 'Show'. So we just do appending here. Fortunately several + -- parse errors on the same line should be relatively rare. + pstateLinePrefix ++ f "" + else f "" + } + ) + where + addPrefix xs = + if sameLine + then pstateLinePrefix ++ xs + else xs + sameLine = sourceLine spos == sourceLine pstateSourcePos + (pre, post) = splitAt' (o - pstateOffset) pstateInput + St spos f = foldl'' go (St pstateSourcePos id) pre + go (St apos g) ch = + let SourcePos n l c = apos + c' = unPos c + w = unPos pstateTabWidth + in if + | ch == newlineTok -> + St + (SourcePos n (l <> pos1) pos1) + id + | ch == tabTok -> + St + (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))) + (g . (fromTok ch :)) + | otherwise -> + St + (SourcePos n l (columnIncrement ch c)) + (g . (fromTok ch :)) +{-# INLINE reachOffset' #-} --- | Update a source position given a token. The first argument specifies --- the tab width. If the character is a newline (\'\\n\') the line number is --- incremented by 1 and column number is reset to 1. If the character is a --- tab (\'\\t\') the column number is incremented to the nearest tab --- position. In all other cases, the column is incremented by 1. +-- | Like 'reachOffset'' but for 'reachOffsetNoLine'. +reachOffsetNoLine' :: + forall s. + (Stream s) => + -- | How to split input stream at given offset + (Int -> s -> (Tokens s, s)) -> + -- | How to fold over input stream + (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) -> + -- | Newline token and tab token + (Token s, Token s) -> + -- | Update column position for a token + (Token s -> Pos -> Pos) -> + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Updated 'PosState' + PosState s +reachOffsetNoLine' + splitAt' + foldl'' + (newlineTok, tabTok) + columnIncrement + o + PosState {..} = + ( PosState + { pstateInput = post, + pstateOffset = max pstateOffset o, + pstateSourcePos = spos, + pstateTabWidth = pstateTabWidth, + pstateLinePrefix = pstateLinePrefix + } + ) + where + spos = foldl'' go pstateSourcePos pre + (pre, post) = splitAt' (o - pstateOffset) pstateInput + go (SourcePos n l c) ch = + let c' = unPos c + w = unPos pstateTabWidth + in if + | ch == newlineTok -> + SourcePos n (l <> pos1) pos1 + | ch == tabTok -> + SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)) + | otherwise -> + SourcePos n l (columnIncrement ch c) +{-# INLINE reachOffsetNoLine' #-} -defaultAdvance1 :: Enum t - => Pos -- ^ Tab width - -> SourcePos -- ^ Current position - -> t -- ^ Current token - -> SourcePos -- ^ Incremented position -defaultAdvance1 width (SourcePos n l c) t = npos +-- | Like 'BL.splitAt' but accepts the index as an 'Int'. +splitAtBL :: Int -> BL.ByteString -> (BL.ByteString, BL.ByteString) +splitAtBL n = BL.splitAt (fromIntegral n) +{-# INLINE splitAtBL #-} + +-- | Like 'TL.splitAt' but accepts the index as an 'Int'. +splitAtTL :: Int -> TL.Text -> (TL.Text, TL.Text) +splitAtTL n = TL.splitAt (fromIntegral n) +{-# INLINE splitAtTL #-} + +-- | @stringPretty s@ returns pretty representation of string @s@. This is +-- used when printing string tokens in error messages. +stringPretty :: NonEmpty Char -> String +stringPretty (x :| []) = charPretty x +stringPretty ('\r' :| "\n") = "crlf newline" +stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\"" where - w = unPos width - c' = unPos c - npos = - case fromEnum t of - 10 -> SourcePos n (l <> pos1) pos1 - 9 -> SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)) - _ -> SourcePos n l (c <> pos1) -{-# INLINE defaultAdvance1 #-} + f ch = + case charPretty' ch of + Nothing -> [ch] + Just pretty -> "<" <> pretty <> ">" + +-- | @charPretty ch@ returns user-friendly string representation of given +-- character @ch@, suitable for using in error messages. +charPretty :: Char -> String +charPretty ' ' = "space" +charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch) + +-- | If the given character has a pretty representation, return that, +-- otherwise 'Nothing'. This is an internal helper. +charPretty' :: Char -> Maybe String +charPretty' = \case + '\NUL' -> Just "null" + '\SOH' -> Just "start of heading" + '\STX' -> Just "start of text" + '\ETX' -> Just "end of text" + '\EOT' -> Just "end of transmission" + '\ENQ' -> Just "enquiry" + '\ACK' -> Just "acknowledge" + '\BEL' -> Just "bell" + '\BS' -> Just "backspace" + '\t' -> Just "tab" + '\n' -> Just "newline" + '\v' -> Just "vertical tab" + '\f' -> Just "form feed" + '\r' -> Just "carriage return" + '\SO' -> Just "shift out" + '\SI' -> Just "shift in" + '\DLE' -> Just "data link escape" + '\DC1' -> Just "device control one" + '\DC2' -> Just "device control two" + '\DC3' -> Just "device control three" + '\DC4' -> Just "device control four" + '\NAK' -> Just "negative acknowledge" + '\SYN' -> Just "synchronous idle" + '\ETB' -> Just "end of transmission block" + '\CAN' -> Just "cancel" + '\EM' -> Just "end of medium" + '\SUB' -> Just "substitute" + '\ESC' -> Just "escape" + '\FS' -> Just "file separator" + '\GS' -> Just "group separator" + '\RS' -> Just "record separator" + '\US' -> Just "unit separator" + '\DEL' -> Just "delete" + '\160' -> Just "non-breaking space" + _ -> Nothing + +-- | Replace tab characters with given number of spaces. +expandTab :: + Pos -> + String -> + String +expandTab w' = go 0 0 + where + go _ 0 [] = [] + go !i 0 ('\t' : xs) = go i (w - (i `rem` w)) xs + go !i 0 (x : xs) = x : go (i + 1) 0 xs + go !i n xs = ' ' : go (i + 1) (n - 1) xs + w = unPos w' + +-- | Return updated column position that corresponds to the given 'Char'. +charInc :: Char -> Pos -> Pos +charInc ch c + | Unicode.isZeroWidthChar ch = c + | Unicode.isWideChar ch = c <> pos1 <> pos1 + | otherwise = c <> pos1 + +-- | Return updated column position that corresponds to the given 'Word8'. +byteInc :: Word8 -> Pos -> Pos +byteInc w c + | w < 0x20 || (w >= 0x7f && w < 0xa0) = c -- C0 and C1 control chars + | otherwise = c <> pos1 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 --- a/bench/memory/Main.hs +++ b/bench/memory/Main.hs @@ -1,43 +1,51 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Control.Monad -import Data.Semigroup ((<>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E import Data.Text (Text) +import qualified Data.Text as T import Data.Void import Text.Megaparsec +import qualified Text.Megaparsec.Byte.Binary as Binary import Text.Megaparsec.Char -import Weigh -import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L - --- | The type of parser that consumes 'String's. +import Weigh +-- | The type of parser that consumes 'Text'. type Parser = Parsec Void Text +-- | The type of parser that consumes 'ByteString'. +type ParserBs = Parsec Void ByteString + main :: IO () main = mainWith $ do setColumns [Case, Allocated, GCs, Max] - bparser "string" manyAs (string . fst) - bparser "string'" manyAs (string' . fst) - bparser "many" manyAs (const $ many (char 'a')) - bparser "some" manyAs (const $ some (char 'a')) - bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) - bparser "count" manyAs (\(_,n) -> count n (char 'a')) - bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) + bparser "string" manyAs (string . fst) + bparser "string'" manyAs (string' . fst) + bparser "many" manyAs (const $ many (char 'a')) + bparser "some" manyAs (const $ some (char 'a')) + bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) + bparser "count" manyAs (\(_, n) -> count n (char 'a')) + bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a')) + bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) + bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) + bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) + bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) + bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) bparser "skipMany" manyAs (const $ skipMany (char 'a')) bparser "skipSome" manyAs (const $ skipSome (char 'a')) - bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) + bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')) bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')) @@ -46,54 +54,174 @@ bparser "octal" mkInt (const (L.octal :: Parser Integer)) bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)) bparser "scientific" mkInt (const L.scientific) + bparserBs "word32be" many0x33 (const $ many Binary.word32be) + bparserBs "word32le" many0x33 (const $ many Binary.word32le) --- | Perform a series of measurements with the same parser. + forM_ stdSeries $ \n -> + bbundle "single error" n [n] -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> Text) -- ^ How to construct input - -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input - -> Weigh () + bbundle "2 errors" 1000 [1, 1000] + bbundle "4 errors" 1000 [1, 500, 1000] + bbundle "100 errors" 1000 [10, 20 .. 1000] + + breachOffset 0 1000 + breachOffset 0 2000 + breachOffset 0 4000 + breachOffset 1000 1000 + + breachOffsetNoLine 0 1000 + breachOffsetNoLine 0 2000 + breachOffsetNoLine 0 4000 + breachOffsetNoLine 1000 1000 + +-- | Perform a series of measurements with the same parser. +bparser :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> Text) -> + -- | The parser receiving its future input + ((Text, Int) -> Parser a) -> + Weigh () bparser name f p = forM_ stdSeries $ \i -> do - let arg = (f i,i) - p' (s,n) = parse (p (s,n)) "" s - func (name ++ "/" ++ show i) p' arg + let arg = (f i, i) + p' (s, n) = parse (p (s, n)) "" s + func (name ++ "-" ++ show i) p' arg --- | The series of sizes to try as part of 'bparser'. +-- | Perform a series of measurements with the same parser. +bparserBs :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> ByteString) -> + -- | The parser receiving its future input + ((ByteString, Int) -> ParserBs a) -> + Weigh () +bparserBs name f p = forM_ stdSeries $ \i -> do + let arg = (f i, i) + p' (s, n) = parse (p (s, n)) "" s + func (name ++ "-" ++ show i) p' arg +-- | Benchmark the 'errorBundlePretty' function. +bbundle :: + -- | Name of the benchmark + String -> + -- | Number of lines in input stream + Int -> + -- | Lines with parse errors + [Int] -> + Weigh () +bbundle name totalLines sps = do + let s = take (totalLines * 80) (cycle as) + as = replicate 79 'a' ++ "\n" + f l = + TrivialError + (20 + l * 80) + (Just $ Tokens ('a' :| "")) + (E.singleton $ Tokens ('b' :| "")) + bundle :: ParseErrorBundle String Void + bundle = + ParseErrorBundle + { bundleErrors = f <$> NE.fromList sps, + bundlePosState = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + } + func + ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) + errorBundlePretty + bundle + +-- | Benchmark the 'reachOffset' function. +breachOffset :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Weigh () +breachOffset o0 o1 = + func + ("reachOffset-" ++ show o0 ++ "-" ++ show o1) + f + (o0 * 80, o1 * 80) + where + f :: (Int, Int) -> PosState Text + f (startOffset, targetOffset) = + snd $ + reachOffset + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + +-- | Benchmark the 'reachOffsetNoLine' function. +breachOffsetNoLine :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Weigh () +breachOffsetNoLine o0 o1 = + func + ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) + f + (o0 * 80, o1 * 80) + where + f :: (Int, Int) -> PosState Text + f (startOffset, targetOffset) = + reachOffsetNoLine + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + +-- | The series of sizes to try as part of 'bparser'. stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] +stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters. - manyAs :: Int -> Text manyAs n = T.replicate n "a" --- | Like 'manyAs', but interspersed with \'b\'s. +-- | Like 'manyAs' but the result is a 'ByteString'. +many0x33 :: Int -> ByteString +many0x33 n = B.replicate n 0x33 +-- | Like 'manyAs', but interspersed with \'b\'s. manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end. - manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'. - manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'. - manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument. - mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100)) diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs --- a/bench/speed/Main.hs +++ b/bench/speed/Main.hs @@ -1,103 +1,221 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Criterion.Main -import Data.Semigroup ((<>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E import Data.Text (Text) +import qualified Data.Text as T import Data.Void import Text.Megaparsec +import qualified Text.Megaparsec.Byte.Binary as Binary import Text.Megaparsec.Char -import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif - --- | The type of parser that consumes 'String's. - +-- | The type of parser that consumes 'Text'. type Parser = Parsec Void Text +-- | The type of parser that consumes 'ByteString'. +type ParserBs = Parsec Void ByteString + main :: IO () -main = defaultMain - [ bparser "string" manyAs (string . fst) - , bparser "string'" manyAs (string' . fst) - , bparser "many" manyAs (const $ many (char 'a')) - , bparser "some" manyAs (const $ some (char 'a')) - , bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) - , bparser "count" manyAs (\(_,n) -> count n (char 'a')) - , bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - , bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - , bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) - , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) - , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - , bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - , bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - , bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) - , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) - , bparser "skipMany" manyAs (const $ skipMany (char 'a')) - , bparser "skipSome" manyAs (const $ skipSome (char 'a')) - , bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) - , bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) - , bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) - , bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')) - , bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a')) - , bparser "decimal" mkInt (const (L.decimal :: Parser Integer)) - , bparser "octal" mkInt (const (L.octal :: Parser Integer)) - , bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)) - , bparser "scientific" mkInt (const L.scientific) - ] +main = + defaultMain + [ bparser "string" manyAs (string . fst), + bparser "string'" manyAs (string' . fst), + bparser "many" manyAs (const $ many (char 'a')), + bparser "some" manyAs (const $ some (char 'a')), + bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd), + bparser "count" manyAs (\(_, n) -> count n (char 'a')), + bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a')), + bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')), + bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')), + bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')), + bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')), + bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')), + bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')), + bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')), + bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')), + bparser "skipMany" manyAs (const $ skipMany (char 'a')), + bparser "skipSome" manyAs (const $ skipSome (char 'a')), + bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')), + bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')), + bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')), + bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')), + bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a')), + bparser "decimal" mkInt (const (L.decimal :: Parser Integer)), + bparser "octal" mkInt (const (L.octal :: Parser Integer)), + bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)), + bparser "scientific" mkInt (const L.scientific), + bparserBs "word32be" many0x33 (const $ many Binary.word32be), + bparserBs "word32le" many0x33 (const $ many Binary.word32le), + bgroup "" [bbundle "single error" n [n] | n <- stdSeries], + bbundle "2 errors" 1000 [1, 1000], + bbundle "4 errors" 1000 [1, 500, 1000], + bbundle "100 errors" 1000 [10, 20 .. 1000], + breachOffset 0 1000, + breachOffset 0 2000, + breachOffset 0 4000, + breachOffset 1000 1000, + breachOffsetNoLine 0 1000, + breachOffsetNoLine 0 2000, + breachOffsetNoLine 0 4000, + breachOffsetNoLine 1000 1000 + ] -- | Perform a series to measurements with the same parser. - -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> Text) -- ^ How to construct input - -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input - -> Benchmark -- ^ The benchmark +bparser :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> Text) -> + -- | The parser receiving its future input + ((Text, Int) -> Parser a) -> + -- | The benchmark + Benchmark bparser name f p = bgroup name (bs <$> stdSeries) where bs n = env (return (f n, n)) (bench (show n) . nf p') - p' (s,n) = parse (p (s,n)) "" s + p' (s, n) = parse (p (s, n)) "" s --- | The series of sizes to try as part of 'bparser'. +-- | Perform a series to measurements with the same parser. +bparserBs :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> ByteString) -> + -- | The parser receiving its future input + ((ByteString, Int) -> ParserBs a) -> + -- | The benchmark + Benchmark +bparserBs name f p = bgroup name (bs <$> stdSeries) + where + bs n = env (return (f n, n)) (bench (show n) . nf p') + p' (s, n) = parse (p (s, n)) "" s +-- | Benchmark the 'errorBundlePretty' function. +bbundle :: + -- | Name of the benchmark + String -> + -- | Number of lines in input stream + Int -> + -- | Lines with parse errors + [Int] -> + Benchmark +bbundle name totalLines sps = + let s = take (totalLines * 80) (cycle as) + as = replicate 79 'a' ++ "\n" + f l = + TrivialError + (20 + l * 80) + (Just $ Tokens ('a' :| "")) + (E.singleton $ Tokens ('b' :| "")) + bundle :: ParseErrorBundle String Void + bundle = + ParseErrorBundle + { bundleErrors = f <$> NE.fromList sps, + bundlePosState = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + } + in bench + ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) + (nf errorBundlePretty bundle) + +-- | Benchmark the 'reachOffset' function. +breachOffset :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Benchmark +breachOffset o0 o1 = + bench + ("reachOffset-" ++ show o0 ++ "-" ++ show o1) + (nf f (o0 * 80, o1 * 80)) + where + f :: (Int, Int) -> PosState Text + f (startOffset, targetOffset) = + snd $ + reachOffset + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + +-- | Benchmark the 'reachOffsetNoLine' function. +breachOffsetNoLine :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Benchmark +breachOffsetNoLine o0 o1 = + bench + ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) + (nf f (o0 * 80, o1 * 80)) + where + f :: (Int, Int) -> PosState Text + f (startOffset, targetOffset) = + reachOffsetNoLine + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } + +-- | The series of sizes to try as part of 'bparser'. stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] +stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters. - manyAs :: Int -> Text manyAs n = T.replicate n "a" --- | Like 'manyAs', but interspersed with \'b\'s. +-- | Like 'manyAs' but the result is a 'ByteString'. +many0x33 :: Int -> ByteString +many0x33 n = B.replicate n 0x33 +-- | Like 'manyAs', but interspersed with \'b\'s. manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end. - manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'. - manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'. - manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument. - mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100)) diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -1,155 +1,127 @@ -name: megaparsec -version: 6.5.0 -cabal-version: 1.18 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1 -license: BSD2 -license-file: LICENSE.md -author: Megaparsec contributors, - Paolo Martini , - 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 an industrial-strength monadic parser combinator library. - Megaparsec is a feature-rich package that strikes a nice balance between - speed, flexibility, and quality of parse errors. +homepage: https://github.com/mrkkrp/megaparsec +bug-reports: https://github.com/mrkkrp/megaparsec/issues +synopsis: Monadic parser combinators +description: + This is an industrial-strength monadic parser combinator library. + Megaparsec is a feature-rich package that tries to find a nice balance + between speed, flexibility, and quality of parse errors. -extra-doc-files: AUTHORS.md - , CHANGELOG.md - , README.md +category: Parsing +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/mrkkrp/megaparsec.git + type: git + location: https://github.com/mrkkrp/megaparsec.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: base >= 4.7 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , case-insensitive >= 1.2 && < 1.3 - , containers >= 0.5 && < 0.6 - , deepseq >= 1.3 && < 1.5 - , mtl >= 2.0 && < 3.0 - , parser-combinators >= 0.4 && < 1.0 - , scientific >= 0.3.1 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - , semigroups == 0.18.* - if !impl(ghc >= 7.10) - build-depends: void == 0.7.* - exposed-modules: Text.Megaparsec - , Text.Megaparsec.Byte - , Text.Megaparsec.Byte.Lexer - , Text.Megaparsec.Char - , Text.Megaparsec.Char.Lexer - , Text.Megaparsec.Error - , Text.Megaparsec.Error.Builder - , Text.Megaparsec.Expr - , Text.Megaparsec.Internal - , Text.Megaparsec.Perm - , Text.Megaparsec.Pos - , Text.Megaparsec.Stream - other-modules: Text.Megaparsec.Class - , Text.Megaparsec.State - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - if flag(dev) && impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - default-language: Haskell2010 + exposed-modules: + Text.Megaparsec + Text.Megaparsec.Byte + Text.Megaparsec.Byte.Binary + Text.Megaparsec.Byte.Lexer + Text.Megaparsec.Char + Text.Megaparsec.Char.Lexer + Text.Megaparsec.Debug + Text.Megaparsec.Error + Text.Megaparsec.Error.Builder + Text.Megaparsec.Internal + Text.Megaparsec.Pos + Text.Megaparsec.State + Text.Megaparsec.Stream + Text.Megaparsec.Unicode -test-suite tests - main-is: Main.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - other-modules: Spec - , Control.Applicative.CombinatorsSpec - , Control.Monad.CombinatorsSpec - , Test.Hspec.Megaparsec - , Test.Hspec.Megaparsec.AdHoc - , Text.Megaparsec.Byte.LexerSpec - , Text.Megaparsec.ByteSpec - , Text.Megaparsec.Char.LexerSpec - , Text.Megaparsec.CharSpec - , Text.Megaparsec.ErrorSpec - , Text.Megaparsec.ExprSpec - , Text.Megaparsec.PermSpec - , Text.Megaparsec.PosSpec - , Text.Megaparsec.StreamSpec - , Text.MegaparsecSpec - build-depends: QuickCheck >= 2.7 && < 2.12 - , base >= 4.7 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.6 - , hspec >= 2.0 && < 3.0 - , hspec-expectations >= 0.5 && < 0.9 - , megaparsec - , mtl >= 2.0 && < 3.0 - , scientific >= 0.3.1 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 - build-tools: hspec-discover >= 2.0 && < 3.0 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - if !impl(ghc >= 7.10) - build-depends: void == 0.7.* - default-language: Haskell2010 + other-modules: + Text.Megaparsec.Class + Text.Megaparsec.Common + Text.Megaparsec.Lexer + default-language: Haskell2010 + build-depends: + array >=0.5.3 && <0.6, + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + mtl >=2.2.2 && <3, + parser-combinators >=1.0 && <2, + scientific >=0.3.7 && <0.4, + text >=0.2 && <2.2, + transformers >=0.4 && <0.7 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + + if impl(ghc >=9.8) + ghc-options: -Wno-x-partial + benchmark bench-speed - main-is: Main.hs - hs-source-dirs: bench/speed - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , criterion >= 0.6.2.1 && < 1.5 - , deepseq >= 1.3 && < 1.5 - , megaparsec - , text >= 0.2 && < 1.3 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - if !impl(ghc >= 7.10) - build-depends: void == 0.7.* - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/speed + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + criterion >=0.6.2.1 && <1.7, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2 + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + benchmark bench-memory - main-is: Main.hs - hs-source-dirs: bench/memory - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 - , deepseq >= 1.3 && < 1.5 - , megaparsec - , text >= 0.2 && < 1.3 - , weigh >= 0.0.4 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - if !impl(ghc >= 7.10) - build-depends: void == 0.7.* - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/memory + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2, + weigh >=0.0.4 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall diff --git a/tests/Control/Applicative/CombinatorsSpec.hs b/tests/Control/Applicative/CombinatorsSpec.hs deleted file mode 100644 --- a/tests/Control/Applicative/CombinatorsSpec.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module Control.Applicative.CombinatorsSpec (spec) where - -import Data.Char (isLetter, isDigit) -import Data.List (intersperse) -import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Char - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif - -spec :: Spec -spec = do - - describe "between" $ - it "works" . property $ \pre c n' post -> do - let p = between (string pre) (string post) (many (char c)) - n = getNonNegative n' - b = length (takeWhile (== c) post) - z = replicate n c - s = pre ++ z ++ post - if b > 0 - then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s) - ( etoks post <> etok c <> - if length post == b - then ueof - else utoks (drop b post) ) - else prs_ p s `shouldParse` z - - describe "choice" $ - it "works" . property $ \cs' s' -> do - let cs = getNonEmpty cs' - p = choice (char <$> cs) - s = [s'] - if s' `elem` cs - then prs_ p s `shouldParse` s' - else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs)) - - describe "count" $ do - it "works" . property $ \n x' -> do - let x = getNonNegative x' - p = count n (char 'x') - p' = count' n n (char 'x') - s = replicate x 'x' - prs_ p s `shouldBe` prs_ p' s - rightOrder (count 3 letterChar) "abc" "abc" - - describe "count'" $ do - it "works" . property $ \m n x' -> do - let x = getNonNegative x' - p = count' m n (char 'x') - s = replicate x 'x' - if | n <= 0 || m > n -> - if x == 0 - then prs_ p s `shouldParse` "" - else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof) - | m <= x && x <= n -> - prs_ p s `shouldParse` s - | x < m -> - prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x') - | otherwise -> - prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof) - rightOrder (count' 1 3 letterChar) "abc" "abc" - - describe "eitherP" $ - it "works" . property $ \ch -> do - let p = eitherP letterChar digitChar - s = pure ch - if | isLetter ch -> prs_ p s `shouldParse` Left ch - | isDigit ch -> prs_ p s `shouldParse` Right ch - | otherwise -> prs_ p s `shouldFailWith` - err posI (utok ch <> elabel "letter" <> elabel "digit") - - describe "endBy" $ do - it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof) - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else eeof) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - rightOrder (endBy letterChar (char ',')) "a,b,c," "abc" - - describe "endBy1" $ do - it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a') - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else mempty) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc" - - describe "manyTill" $ do - it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if c == 0 - then prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - rightOrder (manyTill letterChar (char 'd')) "abcd" "abc" - - describe "someTill" $ do - it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> someTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if | null s -> - prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter") - | c == 0 -> - prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - | s == "c" -> - prs_ p s `shouldFailWith` err - (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter") - | head s == 'c' -> - prs_ p s `shouldParse` ("c", drop 2 s) - | otherwise -> - let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - rightOrder (someTill letterChar (char 'd')) "abcd" "abc" - - describe "option" $ - it "works" . property $ \d a s -> do - let p = option d (string a) - p' = fromMaybe d <$> optional (string a) - prs_ p s `shouldBe` prs_ p' s - - describe "sepBy" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` replicate n 'a' - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI - (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) - (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) - (utok c <> etok '-' <> eeof) - rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc" - - describe "sepBy1" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` replicate n 'a' - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc" - - describe "sepEndBy" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` a - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc" - - describe "sepEndBy1" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy1 (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` a - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc" - - describe "skipMany" $ - it "works" . property $ \c n' a -> do - let p = skipMany (char c) *> string a - n = getNonNegative n' - p' = many (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipSome" $ - it "works" . property $ \c n' a -> do - let p = skipSome (char c) *> string a - n = getNonNegative n' - p' = some (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipCount" $ - it "works" . property $ \c n' a -> do - let p = skipCount n (char c) *> string a - n = getNonNegative n' - p' = count n (char c) *> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipManyTill" $ - it "works" . property $ \c n' a -> c /= a ==> do - let p = skipManyTill (char c) (char a) - n = getNonNegative n' - s = replicate n c ++ [a] - prs_ p s `shouldParse` a - - describe "skipSomeTill" $ - it "works" . property $ \c n' a -> c /= a ==> do - let p = skipSomeTill (char c) (char a) - n = getNonNegative n' - s = replicate n c ++ [a] - if n == 0 - then prs_ p s `shouldFailWith` err posI (utok a <> etok c) - else prs_ p s `shouldParse` a - ----------------------------------------------------------------------------- --- Helpers - -g :: Int -> Int -g x = x + if x > 0 then x - 1 else 0 diff --git a/tests/Control/Monad/CombinatorsSpec.hs b/tests/Control/Monad/CombinatorsSpec.hs deleted file mode 100644 --- a/tests/Control/Monad/CombinatorsSpec.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module Control.Monad.CombinatorsSpec (spec) where - -import Data.List (intersperse) -import Data.Maybe (maybeToList, isNothing, fromJust) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Char - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif - -spec :: Spec -spec = do - - describe "count" $ do - it "works" . property $ \n x' -> do - let x = getNonNegative x' - p = count n (char 'x') - p' = count' n n (char 'x') - s = replicate x 'x' - prs_ p s `shouldBe` prs_ p' s - rightOrder (count 3 letterChar) "abc" "abc" - - describe "count'" $ do - it "works" . property $ \m n x' -> do - let x = getNonNegative x' - p = count' m n (char 'x') - s = replicate x 'x' - if | n <= 0 || m > n -> - if x == 0 - then prs_ p s `shouldParse` "" - else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof) - | m <= x && x <= n -> - prs_ p s `shouldParse` s - | x < m -> - prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x') - | otherwise -> - prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof) - rightOrder (count' 1 3 letterChar) "abc" "abc" - - describe "endBy" $ do - it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof) - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else eeof) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - rightOrder (endBy letterChar (char ',')) "a,b,c," "abc" - - describe "endBy1" $ do - it "works" . property $ \n' c -> do - let n = getNonNegative n' - p = endBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ [c] - if | c == 'a' && n == 0 -> - prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') - | c == 'a' -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') - | c == '-' && n == 0 -> - prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a') - | c /= '-' -> - prs_ p s `shouldFailWith` err (posN (g n) s) - ( utok c <> - (if n > 0 then etok '-' else mempty) <> - (if n == 0 then etok 'a' else mempty) ) - | otherwise -> prs_ p s `shouldParse` replicate n 'a' - rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc" - - describe "manyTill" $ do - it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if c == 0 - then prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - rightOrder (manyTill letterChar (char 'd')) "abcd" "abc" - - describe "someTill" $ do - it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = (,) <$> someTill letterChar (char 'c') <*> many letterChar - s = abcRow a b c - if | null s -> - prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter") - | c == 0 -> - prs_ p s `shouldFailWith` err (posN (a + b) s) - (ueof <> etok 'c' <> elabel "letter") - | s == "c" -> - prs_ p s `shouldFailWith` err - (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter") - | head s == 'c' -> - prs_ p s `shouldParse` ("c", drop 2 s) - | otherwise -> - let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) - rightOrder (someTill letterChar (char 'd')) "abcd" "abc" - - describe "sepBy" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` replicate n 'a' - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI - (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) - (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) - (utok c <> etok '-' <> eeof) - rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc" - - describe "sepBy1" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepBy1 (char 'a') (char '-') - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` replicate n 'a' - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a') - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc" - - describe "sepEndBy" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' -> - prs_ p s `shouldParse` a - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof) - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc" - - describe "sepEndBy1" $ do - it "works" . property $ \n' c' -> do - let n = getNonNegative n' - c = fromJust c' - p = sepEndBy1 (char 'a') (char '-') - a = replicate n 'a' - s = intersperse '-' (replicate n 'a') ++ maybeToList c' - if | isNothing c' && n >= 1 -> - prs_ p s `shouldParse` a - | isNothing c' -> - prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') - | c == 'a' && n == 0 -> - prs_ p s `shouldParse` "a" - | n == 0 -> - prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') - | c == '-' -> - prs_ p s `shouldParse` a - | otherwise -> - prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) - rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc" - - describe "skipMany" $ - it "works" . property $ \c n' a -> do - let p = skipMany (char c) *> string a - n = getNonNegative n' - p' = many (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipSome" $ - it "works" . property $ \c n' a -> do - let p = skipSome (char c) *> string a - n = getNonNegative n' - p' = some (char c) >> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipCount" $ - it "works" . property $ \c n' a -> do - let p = skipCount n (char c) *> string a - n = getNonNegative n' - p' = count n (char c) *> string a - s = replicate n c ++ a - prs_ p s `shouldBe` prs_ p' s - - describe "skipManyTill" $ - it "works" . property $ \c n' a -> c /= a ==> do - let p = skipManyTill (char c) (char a) - n = getNonNegative n' - s = replicate n c ++ [a] - prs_ p s `shouldParse` a - - describe "skipSomeTill" $ - it "works" . property $ \c n' a -> c /= a ==> do - let p = skipSomeTill (char c) (char a) - n = getNonNegative n' - s = replicate n c ++ [a] - if n == 0 - then prs_ p s `shouldFailWith` err posI (utok a <> etok c) - else prs_ p s `shouldParse` a - ----------------------------------------------------------------------------- --- Helpers - -g :: Int -> Int -g x = x + if x > 0 then x - 1 else 0 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main (main) where - -import Test.Hspec.Runner -import Spec (spec) - -main :: IO () -main = hspecWith defaultConfig { configQuickCheckMaxSuccess = Just 1000 } spec 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 -optF --module-name=Spec #-} 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,211 +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 FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Hspec.Megaparsec - ( -- * Basic expectations - shouldParse - , parseSatisfies - , shouldSucceedOn - , shouldFailOn - -- * Testing of error messages - , shouldFailWith - -- * Incremental parsing - , failsLeaving - , succeedsLeaving - , initialState - -- * Re-exports - , module Text.Megaparsec.Error.Builder ) -where - -import Control.Monad (unless) -import Data.List.NonEmpty (NonEmpty (..)) -import Test.Hspec.Expectations -import Text.Megaparsec -import Text.Megaparsec.Error.Builder - ----------------------------------------------------------------------------- --- Basic expectations - --- | Create an expectation by saying what the result should be. --- --- > parse letterChar "" "x" `shouldParse` 'x' - -shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a) - => Either (ParseError t e) a - -- ^ Result of parsing as returned by function like 'parse' - -> a -- ^ Desired result - -> Expectation -r `shouldParse` v = case r of - Left e -> expectationFailure $ "expected: " ++ show v ++ - "\nbut parsing failed with error:\n" ++ showParseError e - Right x -> unless (x == v) . expectationFailure $ - "expected: " ++ show v ++ "\nbut got: " ++ show x - --- | Create an expectation by saying that the parser should successfully --- parse a value and that the value should satisfy some predicate. --- --- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length) - -parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -- ^ Result of parsing as returned by function like 'parse' - -> (a -> Bool) -- ^ Predicate - -> Expectation -r `parseSatisfies` p = case r of - Left e -> expectationFailure $ - "expected a parsed value to check against the predicate" ++ - "\nbut parsing failed with error:\n" ++ showParseError e - Right x -> unless (p x) . expectationFailure $ - "the value did not satisfy the predicate: " ++ show x - --- | Check that a parser fails on a given input. --- --- > parse (char 'x') "" `shouldFailOn` "a" - -shouldFailOn :: Show a - => (s -> Either (ParseError t e) a) - -- ^ Parser that takes stream and produces result or error message - -> s -- ^ Input that the parser should fail on - -> Expectation -p `shouldFailOn` s = shouldFail (p s) - --- | Check that a parser succeeds on a given input. --- --- > parse (char 'x') "" `shouldSucceedOn` "x" - -shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => (s -> Either (ParseError t e) a) - -- ^ Parser that takes stream and produces result or error message - -> s -- ^ Input that the parser should succeed on - -> Expectation -p `shouldSucceedOn` s = shouldSucceed (p s) - ----------------------------------------------------------------------------- --- Testing of error messages - --- | Create an expectation that parser should fail producing certain --- 'ParseError'. Use the 'err' function from this module to construct a --- 'ParseError' to compare with. --- --- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x') - -shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -> ParseError t e - -> Expectation -r `shouldFailWith` e = case r of - Left e' -> unless (e == e') . expectationFailure $ - "the parser is expected to fail with:\n" ++ showParseError e ++ - "but it failed with:\n" ++ showParseError e' - Right v -> expectationFailure $ - "the parser is expected to fail, but it parsed: " ++ show v - ----------------------------------------------------------------------------- --- Incremental parsing - --- | Check that a parser fails and leaves a certain part of input --- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' --- that support incremental parsing. --- --- > runParser' (many (char 'x') <* eof) (initialState "xxa") --- > `failsLeaving` "a" --- --- See also: 'initialState'. - -failsLeaving :: (Show a, Eq s, Show s, Stream s) - => (State s, Either (ParseError (Token s) e) a) - -- ^ Parser that takes stream and produces result along with actual - -- state information - -> s -- ^ Part of input that should be left unconsumed - -> Expectation -(st,r) `failsLeaving` s = - shouldFail r >> checkUnconsumed s (stateInput st) - --- | Check that a parser succeeds and leaves certain part of input --- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' --- that support incremental parsing. --- --- > runParser' (many (char 'x')) (initialState "xxa") --- > `succeedsLeaving` "a" --- --- See also: 'initialState'. - -succeedsLeaving :: ( ShowToken (Token s) - , ShowErrorComponent e - , Show a - , Eq s - , Show s - , Stream s ) - => (State s, Either (ParseError (Token s) e) a) - -- ^ Parser that takes stream and produces result along with actual - -- state information - -> s -- ^ Part of input that should be left unconsumed - -> Expectation -(st,r) `succeedsLeaving` s = - shouldSucceed r >> checkUnconsumed s (stateInput st) - --- | Given input for parsing, construct initial state for parser (that is, --- with empty file name, default tab width and position at 1 line and 1 --- column). - -initialState :: s -> State s -initialState s = State - { stateInput = s - , statePos = initialPos "" :| [] - , stateTokensProcessed = 0 - , stateTabWidth = defaultTabWidth } - ----------------------------------------------------------------------------- --- Helpers - --- | Expectation that argument is result of a failed parser. - -shouldFail :: Show a - => Either (ParseError t e) a - -> Expectation -shouldFail r = case r of - Left _ -> return () - Right v -> expectationFailure $ - "the parser is expected to fail, but it parsed: " ++ show v - --- | Expectation that argument is result of a succeeded parser. - -shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a - -> Expectation -shouldSucceed r = case r of - Left e -> expectationFailure $ - "the parser is expected to succeed, but it failed with:\n" ++ - showParseError e - Right _ -> return () - --- | Compare two streams for equality and in the case of mismatch report it. - -checkUnconsumed :: (Eq s, Show s, Stream s) - => s -- ^ Expected unconsumed input - -> s -- ^ Actual unconsumed input - -> Expectation -checkUnconsumed e a = unless (e == a) . expectationFailure $ - "the parser is expected to leave unconsumed input: " ++ show e ++ - "\nbut it left this: " ++ show a - --- | Render parse error in a way that is suitable for inserting it in a test --- suite report. - -showParseError :: (Ord t, ShowToken t, ShowErrorComponent e) - => ParseError t e - -> String -showParseError = unlines . fmap (" " ++) . lines . parseErrorPretty 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,252 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.Hspec.Megaparsec.AdHoc - ( -- * Helpers to run parsers - prs - , prs' - , prs_ - , grs - , grs' - -- * Working with source position - , updatePosString - , pos1 - , nes - -- * Other - , abcRow - , toFirstMismatch - , rightOrder - , Parser ) -where - -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Trans.Identity -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Proxy -import Data.Void -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.QuickCheck -import Text.Megaparsec -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.State.Lazy as L -import qualified Control.Monad.State.Strict as S -import qualified Control.Monad.Writer.Lazy as L -import qualified Control.Monad.Writer.Strict as S -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - ----------------------------------------------------------------------------- --- Helpers to run parsers - --- | Apply parser to given input. This is a specialized version of 'parse' --- that assumes empty file name. - -prs - :: Parser a -- ^ Parser to run - -> String -- ^ Input for the parser - -> Either (ParseError Char Void) a -- ^ Result of parsing -prs p = parse p "" - --- | Just like 'prs', but allows to inspect the final state of the parser. - -prs' - :: Parser a -- ^ Parser to run - -> String -- ^ Input for the parser - -> (State String, Either (ParseError Char Void) a) -- ^ Result of parsing -prs' p s = runParser' p (initialState s) - --- | Just like 'prs', but forces the parser to consume all input by adding --- 'eof': --- --- > prs_ p = parse (p <* eof) "" - -prs_ - :: Parser a -- ^ Parser to run - -> String -- ^ Input for the parser - -> Either (ParseError Char Void) a -- ^ Result of parsing -prs_ p = parse (p <* eof) "" - --- | Just like 'prs', but interprets given parser as various monads (tries --- all supported monads transformers in turn). - -grs - :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run - -> String -- ^ Input for the parser - -> (Either (ParseError Char Void) a -> Expectation) - -- ^ How to check result of parsing - -> Expectation -grs p s r = do - r (prs p s) - r (prs (runIdentityT p) s) - r (prs (runReaderT p ()) s) - r (prs (L.evalStateT p ()) s) - r (prs (S.evalStateT p ()) s) - r (prs (evalWriterTL p) s) - r (prs (evalWriterTS p) s) - r (prs (evalRWSTL p) s) - r (prs (evalRWSTS p) s) - --- | 'grs'' to 'grs' is as 'prs'' to 'prs'. - -grs' - :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run - -> String -- ^ Input for the parser - -> ((State String, Either (ParseError Char Void) a) -> Expectation) - -- ^ How to check result of parsing - -> Expectation -grs' p s r = do - r (prs' p s) - r (prs' (runIdentityT p) s) - r (prs' (runReaderT p ()) s) - r (prs' (L.evalStateT p ()) s) - r (prs' (S.evalStateT p ()) s) - r (prs' (evalWriterTL p) s) - r (prs' (evalWriterTS p) s) - r (prs' (evalRWSTL p) s) - r (prs' (evalRWSTS p) s) - -evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a -evalWriterTL = liftM fst . L.runWriterT -evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a -evalWriterTS = liftM fst . S.runWriterT - -evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a -evalRWSTL m = do - (a,_,_) <- L.runRWST m () () - return a - -evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a -evalRWSTS m = do - (a,_,_) <- S.runRWST m () () - return a - ----------------------------------------------------------------------------- --- Working with source position - --- | A helper function that is used to advance 'SourcePos' given a 'String'. - -updatePosString - :: Pos -- ^ Tab width - -> SourcePos -- ^ Initial position - -> String -- ^ 'String' — collection of tokens to process - -> SourcePos -- ^ Final position -updatePosString = advanceN (Proxy :: Proxy String) - --- | Make a singleton non-empty list from a value. - -nes :: a -> NonEmpty a -nes x = x :| [] - ----------------------------------------------------------------------------- --- Other - --- | @abcRow a b c@ generates string consisting of character “a” repeated --- @a@ times, character “b” repeated @b@ times, and character “c” repeated --- @c@ times. - -abcRow :: Int -> Int -> Int -> String -abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' - --- | Given a comparing function, get prefix of one string till first --- mismatch with another string (including first mismatching character). - -toFirstMismatch - :: (Char -> Char -> Bool) -- ^ Comparing function - -> String -- ^ First string - -> String -- ^ Second string - -> String -- ^ Resulting prefix -toFirstMismatch f str s = take (n + 1) s - where n = length (takeWhile (uncurry f) (zip str s)) - --- | Check that the given parser returns the list in the right order. - -rightOrder - :: Parser String -- ^ The parser to test - -> String -- ^ Input for the parser - -> String -- ^ Expected result - -> Spec -rightOrder p s s' = - it "produces the list in the right order" $ - prs_ p s `shouldParse` s' - --- | The type of parser that consumes a 'String'. - -type Parser = Parsec Void String - ----------------------------------------------------------------------------- --- Arbitrary instances - -instance Arbitrary Void where - arbitrary = error "Arbitrary Void" - -instance Arbitrary Pos where - arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0)) - -instance Arbitrary SourcePos where - arbitrary = SourcePos - <$> sized (\n -> do - k <- choose (0, n `div` 2) - vectorOf k arbitrary) - <*> arbitrary - <*> arbitrary - -instance Arbitrary t => Arbitrary (ErrorItem t) where - arbitrary = oneof - [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary) - , Label <$> (NE.fromList . getNonEmpty <$> arbitrary) - , return EndOfInput ] - -instance Arbitrary (ErrorFancy a) where - arbitrary = oneof - [ sized (\n -> do - k <- choose (0, n `div` 2) - ErrorFail <$> vectorOf k arbitrary) - , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] - -instance (Arbitrary t, Ord t, Arbitrary e, Ord e) - => Arbitrary (ParseError t e) where - arbitrary = oneof - [ TrivialError - <$> (NE.fromList . getNonEmpty <$> arbitrary) - <*> arbitrary - <*> (E.fromList <$> arbitrary) - , FancyError - <$> (NE.fromList . getNonEmpty <$> arbitrary) - <*> (E.fromList <$> arbitrary) ] - -instance Arbitrary a => Arbitrary (State a) where - arbitrary = State - <$> arbitrary - <*> (NE.fromList . getNonEmpty <$> arbitrary) - <*> choose (1, 10000) - <*> (mkPos <$> choose (1, 20)) - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary TL.Text where - arbitrary = TL.pack <$> arbitrary - -instance Arbitrary B.ByteString where - arbitrary = B.pack <$> arbitrary - -instance Arbitrary BL.ByteString where - arbitrary = BL.pack <$> arbitrary - -#if MIN_VERSION_QuickCheck(2,10,0) -instance Arbitrary a => Arbitrary (NonEmpty a) where - arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null)) -#endif diff --git a/tests/Text/Megaparsec/Byte/LexerSpec.hs b/tests/Text/Megaparsec/Byte/LexerSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/Byte/LexerSpec.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.Megaparsec.Byte.LexerSpec (spec) where - -import Control.Applicative -import Data.ByteString (ByteString) -import Data.Char (toUpper) -import Data.Monoid ((<>)) -import Data.Scientific (Scientific, fromFloatDigits) -import Data.Void -import Data.Word (Word8) -import Numeric (showInt, showHex, showOct, showFFloatAlt) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Byte.Lexer -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Text.Megaparsec.Byte as B - -type Parser = Parsec Void ByteString - -spec :: Spec -spec = do - - describe "skipLineComment" $ do - context "when there is no newline at the end of line" $ - it "is picked up successfully" $ do - let p = space B.space1 (skipLineComment "//") empty <* eof - s = " // this line comment doesn't have a newline at the end " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - it "inner characters are labelled properly" $ do - let p = skipLineComment "//" <* empty - s = "// here we go" - prs p s `shouldFailWith` err (posN (B.length s) s) (elabel "character") - prs' p s `failsLeaving` "" - - describe "skipBlockComment" $ - it "skips a simple block comment" $ do - let p = skipBlockComment "/*" "*/" - s = "/* here we go */foo!" - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "foo!" - - describe "skipBlockCommentNested" $ - context "when it runs into nested block comments" $ - it "parses them all right" $ do - let p = space B.space1 empty - (skipBlockCommentNested "/*" "*/") <* eof - s = " /* foo bar /* baz */ quux */ " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - - describe "decimal" $ do - context "when stream begins with decimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = decimal :: Parser Integer - n = getNonNegative n' - s = B8.pack (showInt n "") - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with decimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = decimal :: Parser Integer - s = B.pack (a : as) - prs p s `shouldFailWith` err posI (utok a <> elabel "integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (decimal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "integer") - - describe "octal" $ do - context "when stream begins with octal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = octal :: Parser Integer - n = getNonNegative n' - s = B8.pack (showOct n "") - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with octal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isOctDigit a) ==> do - let p = octal :: Parser Integer - s = B.pack (a : as) - prs p s `shouldFailWith` - err posI (utok a <> elabel "octal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (octal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "octal integer") - - describe "hexadecimal" $ do - context "when stream begins with hexadecimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = hexadecimal :: Parser Integer - n = getNonNegative n' - s = B8.pack (showHex n "") - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream begins with hexadecimal digits (uppercase)" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = hexadecimal :: Parser Integer - n = getNonNegative n' - s = B8.pack (toUpper <$> showHex n "") - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with hexadecimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isHexDigit a) ==> do - let p = hexadecimal :: Parser Integer - s = B.pack (a : as) - prs p s `shouldFailWith` - err posI (utok a <> elabel "hexadecimal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (hexadecimal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "hexadecimal integer") - - describe "scientific" $ do - context "when stream begins with a number" $ - it "parses it" $ - property $ \n' -> do - let p = scientific :: Parser Scientific - s = B8.pack $ either (show . getNonNegative) (show . getNonNegative) - (n' :: Either (NonNegative Integer) (NonNegative Double)) - prs p s `shouldParse` case n' of - Left x -> fromIntegral (getNonNegative x) - Right x -> fromFloatDigits (getNonNegative x) - prs' p s `succeedsLeaving` "" - context "when fractional part is interrupted" $ - it "signals correct parse error" $ - property $ \(NonNegative n) -> do - let p = scientific <* empty :: Parser Scientific - s = B8.pack (showFFloatAlt Nothing (n :: Double) "") - prs p s `shouldFailWith` err (posN (B.length s) s) - (etok 69 <> etok 101 <> elabel "digit") - prs' p s `failsLeaving` "" - context "when whole part is followed by a dot without valid fractional part" $ - it "parsing of fractional part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = scientific :: Parser Scientific - s = B8.pack $ showInt (n :: Integer) ".err" - prs p s `shouldParse` fromIntegral n - prs' p s `succeedsLeaving` ".err" - context "when number is followed by something starting with 'e'" $ - it "parsing of exponent part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = scientific :: Parser Scientific - s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!" - prs p s `shouldParse` fromFloatDigits n - prs' p s `succeedsLeaving` "err!" - context "when stream is empty" $ - it "signals correct parse error" $ - prs (scientific :: Parser Scientific) "" `shouldFailWith` - err posI (ueof <> elabel "digit") - - describe "float" $ do - context "when stream begins with a float" $ - it "parses it" $ - property $ \n' -> do - let p = float :: Parser Double - n = getNonNegative n' - s = B8.pack (show n) - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with a float" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = float :: Parser Double - s = B.pack (a : as) - prs p s `shouldFailWith` - err posI (utok a <> elabel "digit") - prs' p s `failsLeaving` s - context "when stream begins with an integer (decimal)" $ - it "signals correct parse error" $ - property $ \n' -> do - let p = float :: Parser Double - n = getNonNegative n' - s = B8.pack $ show (n :: Integer) - prs p s `shouldFailWith` err (posN (B.length s) s) - (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit") - prs' p s `failsLeaving` "" - context "when number is followed by something starting with 'e'" $ - it "parsing of exponent part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = float :: Parser Double - s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "err!" - context "when stream is empty" $ - it "signals correct parse error" $ - prs (float :: Parser Double) "" `shouldFailWith` - err posI (ueof <> elabel "digit") - context "when there is float with just exponent" $ - it "parses it all right" $ do - let p = float :: Parser Double - prs p "123e3" `shouldParse` 123e3 - prs' p "123e3" `succeedsLeaving` "" - prs p "123e+3" `shouldParse` 123e+3 - prs' p "123e+3" `succeedsLeaving` "" - prs p "123e-3" `shouldParse` 123e-3 - prs' p "123e-3" `succeedsLeaving` "" - - describe "signed" $ do - context "with integer" $ - it "parses signed integers" $ - property $ \n -> do - let p :: Parser Integer - p = signed (hidden B.space) decimal - s = B8.pack (show n) - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with float" $ - it "parses signed floats" $ - property $ \n -> do - let p :: Parser Double - p = signed (hidden B.space) float - s = B8.pack (show n) - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with scientific" $ - it "parses singed scientific numbers" $ - property $ \n -> do - let p = signed (hidden B.space) scientific - s = B8.pack $ either show show (n :: Either Integer Double) - prs p s `shouldParse` case n of - Left x -> fromIntegral x - Right x -> fromFloatDigits x - context "when number is prefixed with plus sign" $ - it "parses the number" $ - property $ \n' -> do - let p :: Parser Integer - p = signed (hidden B.space) decimal - n = getNonNegative n' - s = B8.pack ('+' : show n) - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when number is prefixed with white space" $ - it "signals correct parse error" $ - property $ \n -> do - let p :: Parser Integer - p = signed (hidden B.space) decimal - s = B8.pack (' ' : show (n :: Integer)) - prs p s `shouldFailWith` err posI - (utok 32 <> etok 43 <> etok 45 <> elabel "integer") - prs' p s `failsLeaving` s - context "when there is white space between sign and digits" $ - it "parses it all right" $ do - let p :: Parser Integer - p = signed (hidden B.space) decimal - s = "- 123" - prs p s `shouldParse` (-123) - prs' p s `succeedsLeaving` "" - ----------------------------------------------------------------------------- --- Helpers - -prs - :: Parser a -- ^ Parser to run - -> ByteString -- ^ Input for the parser - -> Either (ParseError Word8 Void) a -- ^ Result of parsing -prs p = parse p "" - -prs' - :: Parser a -- ^ Parser to run - -> ByteString -- ^ Input for the parser - -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing -prs' p s = runParser' p (initialState s) - -isDigit :: Word8 -> Bool -isDigit w = w - 48 < 10 - -isOctDigit :: Word8 -> Bool -isOctDigit w = w - 48 < 8 - -isHexDigit :: Word8 -> Bool -isHexDigit w = - (w >= 48 && w <= 57) || - (w >= 97 && w <= 102) || - (w >= 65 && w <= 70) diff --git a/tests/Text/Megaparsec/ByteSpec.hs b/tests/Text/Megaparsec/ByteSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/ByteSpec.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Text.Megaparsec.ByteSpec (spec) where - -import Control.Monad -import Data.ByteString (ByteString) -import Data.Char -import Data.Maybe (fromMaybe) -import Data.Proxy -import Data.Semigroup ((<>)) -import Data.Void -import Data.Word (Word8) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc (nes) -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Byte -import qualified Data.ByteString as B - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -type Parser = Parsec Void ByteString - -spec :: Spec -spec = do - - describe "newline" $ - checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline) - - describe "csrf" $ - checkStrLit "crlf newline" "\r\n" crlf - - describe "eol" $ do - context "when stream begins with a newline" $ - it "succeeds returning the newline" $ - property $ \s -> do - let s' = "\n" <> s - prs eol s' `shouldParse` "\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with CRLF sequence" $ - it "parses the CRLF sequence" $ - property $ \s -> do - let s' = "\r\n" <> s - prs eol s' `shouldParse` "\r\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with '\\r', but it's not followed by '\\n'" $ - it "signals correct parse error" $ - property $ \ch -> ch /= 10 ==> do - let s = "\r" <> B.singleton ch - prs eol s `shouldFailWith` - err posI (utoks (B.unpack s) <> elabel "end of line") - context "when input stream is '\\r'" $ - it "signals correct parse error" $ - prs eol "\r" `shouldFailWith` err posI - (utok 13 <> elabel "end of line") - context "when stream does not begin with newline or CRLF sequence" $ - it "signals correct parse error" $ - property $ \ch s -> (ch /= 13 && ch /= 10) ==> do - let s' = B.singleton ch <> s - prs eol s' `shouldFailWith` err posI - (utoks (B.unpack $ B.take 2 s') <> elabel "end of line") - context "when stream is empty" $ - it "signals correct parse error" $ - prs eol "" `shouldFailWith` err posI - (ueof <> elabel "end of line") - - describe "tab" $ - checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab) - - describe "space" $ - it "consumes space up to first non-space character" $ - property $ \s' -> do - let (s0,s1) = B.partition isSpace' s' - s = s0 <> s1 - prs space s `shouldParse` () - prs' space s `succeedsLeaving` s1 - - describe "space1" $ do - context "when stream does not start with a space character" $ - it "signals correct parse error" $ - property $ \ch s' -> not (isSpace' ch) ==> do - let (s0,s1) = B.partition isSpace' s' - s = B.singleton ch <> s0 <> s1 - prs space1 s `shouldFailWith` err posI (utok ch <> elabel "white space") - prs' space1 s `failsLeaving` s - context "when stream starts with a space character" $ - it "consumes space up to first non-space character" $ - property $ \s' -> do - let (s0,s1) = B.partition isSpace' s' - s = " " <> s0 <> s1 - prs space1 s `shouldParse` () - prs' space1 s `succeedsLeaving` s1 - context "when stream is empty" $ - it "signals correct parse error" $ - prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space") - - describe "controlChar" $ - checkCharPred "control character" (isControl . toChar) controlChar - - describe "spaceChar" $ - checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar - - -- describe "upperChar" $ - -- checkCharPred "uppercase letter" (isUpper . toChar) upperChar - - -- describe "lowerChar" $ - -- checkCharPred "lowercase letter" (isLower . toChar) lowerChar - - -- describe "letterChar" $ - -- checkCharPred "letter" (isAlpha . toChar) letterChar - - describe "alphaNumChar" $ - checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar - - describe "printChar" $ - checkCharPred "printable character" (isPrint . toChar) printChar - - describe "digitChar" $ - checkCharRange "digit" [48..57] digitChar - - describe "octDigitChar" $ - checkCharRange "octal digit" [48..55] octDigitChar - - describe "hexDigitChar" $ - checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar - - -- describe "asciiChar" $ - -- checkCharPred "ASCII character" (isAscii . toChar) asciiChar - - describe "char'" $ do - context "when stream begins with the character specified as argument" $ - it "parses the character" $ - property $ \ch s -> do - let sl = B.cons (liftChar toLower ch) s - su = B.cons (liftChar toUpper ch) s - prs (char' ch) sl `shouldParse` liftChar toLower ch - prs (char' ch) su `shouldParse` liftChar toUpper ch - prs' (char' ch) sl `succeedsLeaving` s - prs' (char' ch) su `succeedsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch ch' s -> liftChar toLower ch /= liftChar toLower ch' ==> do - let s' = B.cons ch' s - ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch) - prs (char' ch) s' `shouldFailWith` err posI ms - prs' (char' ch) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> do - let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch) - prs (char' ch) "" `shouldFailWith` err posI ms - ----------------------------------------------------------------------------- --- Helpers - -checkStrLit :: String -> ByteString -> Parser ByteString -> SpecWith () -checkStrLit name ts p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \s -> do - let s' = ts <> s - prs p s' `shouldParse` ts - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> ch /= B.head ts ==> do - let s' = B.cons ch s - us = B.unpack $ B.take (B.length ts) s' - ps = B.unpack ts - prs p s' `shouldFailWith` err posI (utoks us <> etoks ps) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> etoks (B.unpack ts)) - -checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith () -checkCharPred name f p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \ch s -> f ch ==> do - let s' = B.singleton ch <> s - prs p s' `shouldParse` ch - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> not (f ch) ==> do - let s' = B.singleton ch <> s - prs p s' `shouldFailWith` err posI (utok ch <> elabel name) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - -checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith () -checkCharRange name tchs p = do - forM_ tchs $ \tch -> - context ("when stream begins with " ++ showTokens (nes tch)) $ - it ("parses the " ++ showTokens (nes tch)) $ - property $ \s -> do - let s' = B.singleton tch <> s - prs p s' `shouldParse` tch - prs' p s' `succeedsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - -prs - :: Parser a -- ^ Parser to run - -> ByteString -- ^ Input for the parser - -> Either (ParseError Word8 Void) a -- ^ Result of parsing -prs p = parse p "" - -prs' - :: Parser a -- ^ Parser to run - -> ByteString -- ^ Input for the parser - -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing -prs' p s = runParser' p (initialState s) - -bproxy :: Proxy ByteString -bproxy = Proxy - --- | 'Word8'-specialized version of 'isSpace'. - -isSpace' :: Word8 -> Bool -isSpace' x - | x >= 9 && x <= 13 = True - | x == 32 = True - | x == 160 = True - | otherwise = False - --- | Convert a byte to char. - -toChar :: Word8 -> Char -toChar = chr . fromIntegral - --- | Covert a char to byte. - -fromChar :: Char -> Maybe Word8 -fromChar x = let p = ord x in - if p > 0xff - then Nothing - else Just (fromIntegral p) - --- | Lift char transformation to byte transformation. - -liftChar :: (Char -> Char) -> Word8 -> Word8 -liftChar f x = (fromMaybe x . fromChar . f . toChar) x diff --git a/tests/Text/Megaparsec/Char/LexerSpec.hs b/tests/Text/Megaparsec/Char/LexerSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/Char/LexerSpec.hs +++ /dev/null @@ -1,543 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -module Text.Megaparsec.Char.LexerSpec (spec) where - -import Control.Monad -import Data.Char hiding (ord) -import Data.List (isInfixOf) -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Scientific (Scientific, fromFloatDigits) -import Data.Void (Void) -import Numeric (showInt, showHex, showOct, showFFloatAlt) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Char.Lexer -import qualified Text.Megaparsec.Char as C - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif - -spec :: Spec -spec = do - - describe "space" $ - it "consumes any sort of white space" $ - property $ forAll mkWhiteSpace $ \s -> do - prs scn s `shouldParse` () - prs' scn s `succeedsLeaving` "" - - describe "symbol" $ - context "when stream begins with the symbol" $ - it "parses the symbol and trailing whitespace" $ - property $ forAll mkSymbol $ \s -> do - let p = symbol scn y - y = takeWhile (not . isSpace) s - prs p s `shouldParse` y - prs' p s `succeedsLeaving` "" - - describe "symbol'" $ - context "when stream begins with the symbol" $ - it "parses the symbol and trailing whitespace" $ - property $ forAll mkSymbol $ \s -> do - let p = symbol' scn y' - y' = toUpper <$> y - y = takeWhile (not . isSpace) s - -- NOTE In some rare cases it's possible that y' will have a - -- different length than y due to the craziness of Unicode. We - -- cannot deal with those cases due to how the tokens primitive is - -- implemented. This is a “feature”, not a bug. - when (length y' /= length y) discard - prs p s `shouldParse` y - prs' p s `succeedsLeaving` "" - - describe "skipLineComment" $ do - context "when there is no newline at the end of line" $ - it "is picked up successfully" $ do - let p = skipLineComment "//" - s = "// this line comment doesn't have a newline at the end " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - it "inner characters are labelled properly" $ do - let p = skipLineComment "//" <* empty - s = "// here we go" - prs p s `shouldFailWith` err (posN (length s) s) (elabel "character") - prs' p s `failsLeaving` "" - - describe "skipBlockComment" $ - it "skips a simple block comment" $ do - let p = skipBlockComment "/*" "*/" - s = "/* here we go */foo!" - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "foo!" - - describe "skipBlockCommentNested" $ - context "when it runs into nested block comments" $ - it "parses them all right" $ do - let p = space (void C.spaceChar) empty - (skipBlockCommentNested "/*" "*/") <* eof - s = " /* foo bar /* baz */ quux */ " - prs p s `shouldParse` () - prs' p s `succeedsLeaving` "" - - describe "indentLevel" $ - it "returns current indentation level (column)" $ - property $ \pos -> do - let p = setPosition pos *> indentLevel - prs p "" `shouldParse` sourceColumn pos - - describe "incorrectIndent" $ - it "signals correct parse error" $ - property $ \ord ref actual -> do - let p :: Parser () - p = incorrectIndent ord ref actual - prs p "" `shouldFailWith` errFancy posI (ii ord ref actual) - - describe "indentGuard" $ - it "works as intended" $ - property $ \n -> do - let mki = mkIndent sbla (getSmall $ getNonNegative n) - forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do - let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) - fragments = [l0,l1,l2] - g x = sum (length <$> take x fragments) - s = concat fragments - p = ip GT pos1 >>= - \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn - ip = indentGuard scn - sp = void (symbol sc sbla <* C.eol) - if | col0 <= pos1 -> - prs p s `shouldFailWith` errFancy posI (ii GT pos1 col0) - | col1 /= col0 -> - prs p s `shouldFailWith` errFancy (posN (getIndent l1 + g 1) s) (ii EQ col0 col1) - | col2 <= col0 -> - prs p s `shouldFailWith` errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2) - | otherwise -> - prs p s `shouldParse` () - - describe "nonIdented" $ - it "works as intended" $ - property $ forAll (mkIndent sbla 0) $ \s -> do - let p = nonIndented scn (symbol scn sbla) - i = getIndent s - if i == 0 - then prs p s `shouldParse` sbla - else prs p s `shouldFailWith` errFancy (posN i s) (ii EQ pos1 (getCol s)) - - describe "indentBlock" $ do - it "works as indented" $ - property $ \mn'' -> do - let mkBlock = do - l0 <- mkIndent sbla 0 - l1 <- mkIndent sblb ib - l2 <- mkIndent sblc (ib + 2) - l3 <- mkIndent sblb ib - l4 <- mkIndent' sblc (ib + 2) - return (l0,l1,l2,l3,l4) - ib = fromMaybe 2 mn' - mn' = getSmall . getPositive <$> mn'' - mn = mkPos . fromIntegral <$> mn' - forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do - let (col0, col1, col2, col3, col4) = - (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4) - fragments = [l0,l1,l2,l3,l4] - g x = sum (length <$> take x fragments) - s = concat fragments - p = lvla <* eof - lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla - lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb - lvlc = indentBlock scn $ IndentNone sblc <$ b sblc - b = symbol sc - l x = return . (x,) - ib' = mkPos (fromIntegral ib) - if | col1 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof) - | isJust mn && col1 /= ib' -> prs p s `shouldFailWith` - errFancy (posN (getIndent l1 + g 1) s) (ii EQ ib' col1) - | col2 <= col1 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l2 + g 2) s) (ii GT col1 col2) - | col3 == col2 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (utoks sblb <> etoks sblc <> eeof) - | col3 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof) - | col3 < col1 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l3 + g 3) s) (ii EQ col1 col3) - | col3 > col1 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l3 + g 3) s) (ii EQ col2 col3) - | col4 <= col3 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l4 + g 4) s) (ii GT col3 col4) - | otherwise -> prs p s `shouldParse` - (sbla, [(sblb, [sblc]), (sblb, [sblc])]) - it "IndentMany works as intended (newline at the end)" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs p s `shouldParse` (sbla, []) - prs' p s `succeedsLeaving` "" - it "IndentMany works as intended (eof)" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs p s `shouldParse` (sbla, []) - prs' p s `succeedsLeaving` "" - it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do - let p = lvla - lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - s = "aaa\n bbb\n " - prs p s `shouldParse` (sbla, [sblb]) - prs' p s `succeedsLeaving` "" - it "works with many and both IndentMany and IndentNone" $ - property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do - let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla - p2 = indentBlock scn $ IndentNone sbla <$ b sbla - lvlb = b sblb - b = symbol sc - l x = return . (x,) - prs (many p1) s `shouldParse` [(sbla, [])] - prs (many p2) s `shouldParse` [sbla] - prs' (many p1) s `succeedsLeaving` "" - prs' (many p2) s `succeedsLeaving` "" - it "IndentSome expects the specified indentation level for first item" $ do - let s = "aaa\n bbb\n" - p = indentBlock scn $ - IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla - lvlb = symbol sc sblb - l x = return . (x,) - prs p s `shouldFailWith` errFancy (posN 6 s) - (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3)) - - describe "lineFold" $ - it "works as intended" $ - property $ do - let mkFold = do - l0 <- mkInterspace sbla 0 - l1 <- mkInterspace sblb 1 - l2 <- mkInterspace sblc 1 - return (l0,l1,l2) - forAll mkFold $ \(l0,l1,l2) -> do - let p = lineFold scn $ \sc' -> do - a <- symbol sc' sbla - b <- symbol sc' sblb - c <- symbol scn sblc - return (a, b, c) - getEnd x = last x == '\n' - fragments = [l0,l1,l2] - g x = sum (length <$> take x fragments) - s = concat fragments - (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) - (end0, end1) = (getEnd l0, getEnd l1) - if | end0 && col1 <= col0 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l1 + g 1) s) (ii GT col0 col1) - | end1 && col2 <= col0 -> prs p s `shouldFailWith` - errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2) - | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) - - describe "charLiteral" $ do - context "when stream begins with a literal character" $ - it "parses it" $ - property $ \ch -> do - let p = charLiteral - s = showLitChar ch "" - prs p s `shouldParse` ch - prs' p s `succeedsLeaving` "" - context "when stream does not begin with a literal character" $ - it "signals correct parse error" $ do - let p = charLiteral - s = "\\" - prs p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character") - prs' p s `failsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ do - let p = charLiteral - prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character") - - describe "decimal" $ do - context "when stream begins with decimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = decimal :: Parser Integer - n = getNonNegative n' - s = showInt n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with decimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = decimal :: Parser Integer - s = a : as - prs p s `shouldFailWith` err posI (utok a <> elabel "integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (decimal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "integer") - - describe "octal" $ do - context "when stream begins with octal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = octal :: Parser Integer - n = getNonNegative n' - s = showOct n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with octal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isOctDigit a) ==> do - let p = octal :: Parser Integer - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "octal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (octal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "octal integer") - - describe "hexadecimal" $ do - context "when stream begins with hexadecimal digits" $ - it "they are parsed as an integer" $ - property $ \n' -> do - let p = hexadecimal :: Parser Integer - n = getNonNegative n' - s = showHex n "" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with hexadecimal digits" $ - it "signals correct parse error" $ - property $ \a as -> not (isHexDigit a) ==> do - let p = hexadecimal :: Parser Integer - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "hexadecimal integer") - context "when stream is empty" $ - it "signals correct parse error" $ - prs (hexadecimal :: Parser Integer) "" `shouldFailWith` - err posI (ueof <> elabel "hexadecimal integer") - - describe "scientific" $ do - context "when stream begins with a number" $ - it "parses it" $ - property $ \n' -> do - let p = scientific :: Parser Scientific - s = either (show . getNonNegative) (show . getNonNegative) - (n' :: Either (NonNegative Integer) (NonNegative Double)) - prs p s `shouldParse` case n' of - Left x -> fromIntegral (getNonNegative x) - Right x -> fromFloatDigits (getNonNegative x) - prs' p s `succeedsLeaving` "" - context "when fractional part is interrupted" $ - it "signals correct parse error" $ - property $ \(NonNegative n) -> do - let p = scientific <* empty :: Parser Scientific - s = showFFloatAlt Nothing (n :: Double) "" - prs p s `shouldFailWith` err (posN (length s) s) - (etok 'E' <> etok 'e' <> elabel "digit") - prs' p s `failsLeaving` "" - context "when whole part is followed by a dot without valid fractional part" $ - it "parsing of fractional part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = scientific :: Parser Scientific - s = showInt (n :: Integer) ".err" - prs p s `shouldParse` fromIntegral n - prs' p s `succeedsLeaving` ".err" - context "when number is followed by something starting with 'e'" $ - it "parsing of exponent part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = scientific :: Parser Scientific - s = showFFloatAlt Nothing (n :: Double) "err!" - prs p s `shouldParse` fromFloatDigits n - prs' p s `succeedsLeaving` "err!" - context "when stream is empty" $ - it "signals correct parse error" $ - prs (scientific :: Parser Scientific) "" `shouldFailWith` - err posI (ueof <> elabel "digit") - - describe "float" $ do - context "when stream begins with a float" $ - it "parses it" $ - property $ \n' -> do - let p = float :: Parser Double - n = getNonNegative n' - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when stream does not begin with a float" $ - it "signals correct parse error" $ - property $ \a as -> not (isDigit a) ==> do - let p = float :: Parser Double - s = a : as - prs p s `shouldFailWith` - err posI (utok a <> elabel "digit") - prs' p s `failsLeaving` s - context "when stream begins with an integer (decimal)" $ - it "signals correct parse error" $ - property $ \n' -> do - let p = float :: Parser Double - n = getNonNegative n' - s = show (n :: Integer) - prs p s `shouldFailWith` err (posN (length s) s) - (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit") - prs' p s `failsLeaving` "" - context "when number is followed by something starting with 'e'" $ - it "parsing of exponent part is backtracked correctly" $ - property $ \(NonNegative n) -> do - let p = float :: Parser Double - s = showFFloatAlt Nothing (n :: Double) "err!" - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "err!" - context "when stream is empty" $ - it "signals correct parse error" $ - prs (float :: Parser Double) "" `shouldFailWith` - err posI (ueof <> elabel "digit") - context "when there is float with just exponent" $ - it "parses it all right" $ do - let p = float :: Parser Double - prs p "123e3" `shouldParse` 123e3 - prs' p "123e3" `succeedsLeaving` "" - prs p "123e+3" `shouldParse` 123e+3 - prs' p "123e+3" `succeedsLeaving` "" - prs p "123e-3" `shouldParse` 123e-3 - prs' p "123e-3" `succeedsLeaving` "" - - describe "signed" $ do - context "with integer" $ - it "parses signed integers" $ - property $ \n -> do - let p :: Parser Integer - p = signed (hidden C.space) decimal - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with float" $ - it "parses signed floats" $ - property $ \n -> do - let p :: Parser Double - p = signed (hidden C.space) float - s = show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "with scientific" $ - it "parses singed scientific numbers" $ - property $ \n -> do - let p = signed (hidden C.space) scientific - s = either show show (n :: Either Integer Double) - prs p s `shouldParse` case n of - Left x -> fromIntegral x - Right x -> fromFloatDigits x - context "when number is prefixed with plus sign" $ - it "parses the number" $ - property $ \n' -> do - let p :: Parser Integer - p = signed (hidden C.space) decimal - n = getNonNegative n' - s = '+' : show n - prs p s `shouldParse` n - prs' p s `succeedsLeaving` "" - context "when number is prefixed with white space" $ - it "signals correct parse error" $ - property $ \n -> do - let p :: Parser Integer - p = signed (hidden C.space) decimal - s = ' ' : show (n :: Integer) - prs p s `shouldFailWith` err posI - (utok ' ' <> etok '+' <> etok '-' <> elabel "integer") - prs' p s `failsLeaving` s - context "when there is white space between sign and digits" $ - it "parses it all right" $ do - let p :: Parser Integer - p = signed (hidden C.space) decimal - s = "- 123" - prs p s `shouldParse` (-123) - prs' p s `succeedsLeaving` "" - ----------------------------------------------------------------------------- --- Helpers - -mkWhiteSpace :: Gen String -mkWhiteSpace = concat <$> listOf whiteUnit - where - whiteUnit = oneof [whiteChars, whiteLine, whiteBlock] - -mkWhiteSpaceNl :: Gen String -mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n" - -mkSymbol :: Gen String -mkSymbol = (++) <$> symbolName <*> whiteChars - -mkInterspace :: String -> Int -> Gen String -mkInterspace x n = oneof [si, mkIndent x n] - where - si = (++ x) <$> listOf (elements " \t") - -mkIndent :: String -> Int -> Gen String -mkIndent x n = (++) <$> mkIndent' x n <*> eol - where - eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))] - -mkIndent' :: String -> Int -> Gen String -mkIndent' x n = concat <$> sequence [spc, sym, tra] - where - spc = frequency [(5, vectorOf n itm), (1, listOf itm)] - tra = listOf itm - itm = elements " \t" - sym = return x - -whiteChars :: Gen String -whiteChars = listOf (elements "\t\n ") - -whiteLine :: Gen String -whiteLine = commentOut <$> arbitrary `suchThat` goodEnough - where - commentOut x = "//" ++ x ++ "\n" - goodEnough x = '\n' `notElem` x - -whiteBlock :: Gen String -whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough - where - commentOut x = "/*" ++ x ++ "*/" - goodEnough x = not $ "*/" `isInfixOf` x - -symbolName :: Gen String -symbolName = listOf $ arbitrary `suchThat` isAlphaNum - -sc :: Parser () -sc = space (void $ takeWhile1P Nothing f) empty empty - where - f x = x == ' ' || x == '\t' - -scn :: Parser () -scn = space C.space1 l b - where - l = skipLineComment "//" - b = skipBlockComment "/*" "*/" - -getIndent :: String -> Int -getIndent = length . takeWhile isSpace - -getCol :: String -> Pos -getCol x = sourceColumn . - updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x - -sbla, sblb, sblc :: String -sbla = "aaa" -sblb = "bbb" -sblc = "ccc" - -ii :: Ordering -> Pos -> Pos -> EF Void -ii ord ref actual = fancy (ErrorIndentation ord ref actual) 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,403 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.Megaparsec.CharSpec (spec) where - -import Control.Monad -import Data.Char -import Data.List (partition, isPrefixOf) -import Data.Monoid ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Char - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -instance Arbitrary GeneralCategory where - arbitrary = elements [minBound..maxBound] - -spec :: Spec -spec = do - - describe "newline" $ - checkStrLit "newline" "\n" (pure <$> newline) - - describe "csrf" $ - checkStrLit "crlf newline" "\r\n" crlf - - describe "eol" $ do - context "when stream begins with a newline" $ - it "succeeds returning the newline" $ - property $ \s -> do - let s' = '\n' : s - prs eol s' `shouldParse` "\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with CRLF sequence" $ - it "parses the CRLF sequence" $ - property $ \s -> do - let s' = '\r' : '\n' : s - prs eol s' `shouldParse` "\r\n" - prs' eol s' `succeedsLeaving` s - context "when stream begins with '\\r', but it's not followed by '\\n'" $ - it "signals correct parse error" $ - property $ \ch -> ch /= '\n' ==> do - let s = ['\r',ch] - prs eol s `shouldFailWith` err posI (utoks s <> elabel "end of line") - context "when input stream is '\\r'" $ - it "signals correct parse error" $ - prs eol "\r" `shouldFailWith` err posI - (utok '\r' <> elabel "end of line") - context "when stream does not begin with newline or CRLF sequence" $ - it "signals correct parse error" $ - property $ \ch s -> (ch `notElem` "\r\n") ==> do - let s' = ch : s - prs eol s' `shouldFailWith` err posI - (utoks (take 2 s') <> elabel "end of line") - context "when stream is empty" $ - it "signals correct parse error" $ - prs eol "" `shouldFailWith` err posI - (ueof <> elabel "end of line") - - describe "tab" $ - checkStrLit "tab" "\t" (pure <$> tab) - - describe "space" $ - it "consumes space up to first non-space character" $ - property $ \s' -> do - let (s0,s1) = partition isSpace s' - s = s0 ++ s1 - prs space s `shouldParse` () - prs' space s `succeedsLeaving` s1 - - describe "space1" $ do - context "when stream does not start with a space character" $ - it "signals correct parse error" $ - property $ \ch s' -> not (isSpace ch) ==> do - let (s0,s1) = partition isSpace s' - s = ch : s0 ++ s1 - prs space1 s `shouldFailWith` err posI (utok ch <> elabel "white space") - prs' space1 s `failsLeaving` s - context "when stream starts with a space character" $ - it "consumes space up to first non-space character" $ - property $ \s' -> do - let (s0,s1) = partition isSpace s' - s = ' ' : s0 ++ s1 - prs space1 s `shouldParse` () - prs' space1 s `succeedsLeaving` s1 - context "when stream is empty" $ - it "signals correct parse error" $ - prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space") - - describe "controlChar" $ - checkCharPred "control character" isControl controlChar - - describe "spaceChar" $ - checkCharRange "white space" " \160\t\n\r\f\v" spaceChar - - describe "upperChar" $ - checkCharPred "uppercase letter" isUpper upperChar - - describe "lowerChar" $ - checkCharPred "lowercase letter" isLower lowerChar - - describe "letterChar" $ - checkCharPred "letter" isAlpha letterChar - - describe "alphaNumChar" $ - checkCharPred "alphanumeric character" isAlphaNum alphaNumChar - - describe "printChar" $ - checkCharPred "printable character" isPrint printChar - - describe "digitChar" $ - checkCharRange "digit" ['0'..'9'] digitChar - - describe "octDigitChar" $ - checkCharRange "octal digit" ['0'..'7'] octDigitChar - - describe "hexDigitChar" $ - checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar - - describe "markChar" $ -#if MIN_VERSION_base(4,9,0) - checkCharRange "mark character" "\71229\7398" markChar -#else - checkCharRange "mark character" "" markChar -#endif - - describe "numberChar" $ - let xs = "\185\178\179\188\189\190" ++ ['0'..'9'] - in checkCharRange "numeric character" xs numberChar - - describe "punctuationChar" $ - checkCharPred "punctuation" isPunctuation punctuationChar - - describe "symbolChar" $ -#if MIN_VERSION_base(4,8,0) - checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar -#else - checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar -#endif - describe "separatorChar" $ - checkCharRange "separator" " \160" separatorChar - - describe "asciiChar" $ - checkCharPred "ASCII character" isAscii asciiChar - - describe "latin1Char" $ do - context "when stream begins with Latin-1 character" $ - it "parses the Latin-1 character" $ - property $ \ch s -> isLatin1 ch ==> do - let s' = ch : s - prs latin1Char s' `shouldParse` ch - prs' latin1Char s' `succeedsLeaving` s - context "when stream does not begin with Latin-1 character" $ - it "signals correct parse error" $ do - prs latin1Char "б" `shouldFailWith` - err posI (utok 'б' <> elabel "Latin-1 character") - prs' latin1Char "в" `failsLeaving` "в" - context "when stream is empty" $ - it "signals correct parse error" $ - prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character") - - describe "charCategory" $ do - context "when parser corresponding to general category of next char is used" $ - it "succeeds" $ - property $ \ch s -> do - let s' = ch : s - g = generalCategory ch - prs (charCategory g) s' `shouldParse` ch - prs' (charCategory g) s' `succeedsLeaving` s - context "when parser's category does not match next character's category" $ - it "fails" $ - property $ \g ch s -> (generalCategory ch /= g) ==> do - let s' = ch : s - prs (charCategory g) s' `shouldFailWith` - err posI (utok ch <> elabel (categoryName g)) - prs' (charCategory g) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \g -> - prs (charCategory g) "" `shouldFailWith` - err posI (ueof <> elabel (categoryName g)) - - describe "char" $ do - context "when stream begins with the character specified as argument" $ - it "parses the character" $ - property $ \ch s -> do - let s' = ch : s - prs (char ch) s' `shouldParse` ch - prs' (char ch) s' `succeedsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch ch' s -> ch /= ch' ==> do - let s' = ch' : s - prs (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch) - prs' (char ch) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> - prs (char ch) "" `shouldFailWith` err posI (ueof <> etok ch) - - describe "char'" $ do - let goodChar x = - (toUpper x == toLower x) || (isUpper x || isLower x) - context "when stream begins with the character specified as argument" $ - it "parses the character" $ - property $ \ch s -> goodChar ch ==> do - let sl = toLower ch : s - su = toUpper ch : s - prs (char' ch) sl `shouldParse` toLower ch - prs (char' ch) su `shouldParse` toUpper ch - prs' (char' ch) sl `succeedsLeaving` s - prs' (char' ch) su `succeedsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch ch' s -> goodChar ch && toLower ch /= toLower ch' ==> do - let s' = ch' : s - ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) - prs (char' ch) s' `shouldFailWith` err posI ms - prs' (char' ch) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> goodChar ch ==> do - let ms = ueof <> etok (toLower ch) <> etok (toUpper ch) - prs (char' ch) "" `shouldFailWith` err posI ms - - describe "anyChar" $ do - context "when stream is not empty" $ - it "succeeds consuming next character in the stream" $ - property $ \ch s -> do - let s' = ch : s - prs anyChar s' `shouldParse` ch - prs' anyChar s' `succeedsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character") - - describe "notChar" $ do - context "when stream begins with the character specified as argument" $ - it "signals correct parse error" $ - property $ \ch s' -> do - let p = notChar ch - s = ch : s' - prs p s `shouldFailWith` err posI (utok ch) - prs' p s `failsLeaving` s - context "when stream does not begin with the character specified as argument" $ - it "parses first character in the stream" $ - property $ \ch s -> not (null s) && ch /= head s ==> do - let p = notChar ch - prs p s `shouldParse` head s - prs' p s `succeedsLeaving` tail s - context "when stream is empty" $ - it "signals correct parse error" $ - prs (notChar 'a') "" `shouldFailWith` err posI ueof - - describe "oneOf" $ do - context "when stream begins with one of specified characters" $ - it "parses the character" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - s' = ch : s - prs (oneOf chs) s' `shouldParse` ch - prs' (oneOf chs) s' `succeedsLeaving` s - context "when stream does not begin with any of specified characters" $ - it "signals correct parse error" $ - property $ \chs ch s -> ch `notElem` (chs :: String) ==> do - let s' = ch : s - prs (oneOf chs) s' `shouldFailWith` err posI (utok ch) - prs' (oneOf chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "noneOf" $ do - context "when stream does not begin with any of specified characters" $ - it "parses the character" $ - property $ \chs ch s -> ch `notElem` (chs :: String) ==> do - let s' = ch : s - prs (noneOf chs) s' `shouldParse` ch - prs' (noneOf chs) s' `succeedsLeaving` s - context "when stream begins with one of specified characters" $ - it "signals correct parse error" $ - property $ \chs' n s -> do - let chs = getNonEmpty chs' - ch = chs !! (getNonNegative n `rem` length chs) - s' = ch : s - prs (noneOf chs) s' `shouldFailWith` err posI (utok ch) - prs' (noneOf chs) s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \chs -> - prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof - - describe "string" $ do - context "when stream is prefixed with given string" $ - it "parses the string" $ - property $ \str s -> do - let s' = str ++ s - prs (string str) s' `shouldParse` str - prs' (string str) s' `succeedsLeaving` s - context "when stream is not prefixed with given string" $ - it "signals correct parse error" $ - property $ \str s -> not (str `isPrefixOf` s) ==> do - let us = take (length str) s - prs (string str) s `shouldFailWith` - err posI (utoks us <> etoks str) - - describe "string'" $ do - context "when stream is prefixed with given string" $ - it "parses the string" $ - property $ \str s -> - forAll (fuzzyCase str) $ \str' -> do - let s' = str' ++ s - prs (string' str) s' `shouldParse` str' - prs' (string' str) s' `succeedsLeaving` s - context "when stream is not prefixed with given string" $ - it "signals correct parse error" $ - property $ \str s -> not (str `isPrefixOfI` s) ==> do - let us = take (length str) s - prs (string' str) s `shouldFailWith` - err posI (utoks us <> etoks str) - ----------------------------------------------------------------------------- --- Helpers - -checkStrLit :: String -> String -> Parser String -> SpecWith () -checkStrLit name ts p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \s -> do - let s' = ts ++ s - prs p s' `shouldParse` ts - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> ch /= head ts ==> do - let s' = ch : s - us = take (length ts) s' - prs p s' `shouldFailWith` err posI (utoks us <> etoks ts) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> etoks ts) - -checkCharPred :: String -> (Char -> Bool) -> Parser Char -> SpecWith () -checkCharPred name f p = do - context ("when stream begins with " ++ name) $ - it ("parses the " ++ name) $ - property $ \ch s -> f ch ==> do - let s' = ch : s - prs p s' `shouldParse` ch - prs' p s' `succeedsLeaving` s - context ("when stream does not begin with " ++ name) $ - it "signals correct parse error" $ - property $ \ch s -> not (f ch) ==> do - let s' = ch : s - prs p s' `shouldFailWith` err posI (utok ch <> elabel name) - prs' p s' `failsLeaving` s' - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - -checkCharRange :: String -> String -> Parser Char -> SpecWith () -checkCharRange name tchs p = do - forM_ tchs $ \tch -> - context ("when stream begins with " ++ showTokens (nes tch)) $ - it ("parses the " ++ showTokens (nes tch)) $ - property $ \s -> do - let s' = tch : s - prs p s' `shouldParse` tch - prs' p s' `succeedsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - prs p "" `shouldFailWith` err posI (ueof <> elabel name) - --- | Randomly change the case in the given string. - -fuzzyCase :: String -> Gen String -fuzzyCase s = zipWith f s <$> vector (length s) - where - f k True = if isLower k then toUpper k else toLower k - f k False = k - --- | Case-insensitive equality test for characters. - -casei :: Char -> Char -> Bool -casei x y = toUpper x == toUpper y - --- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff --- the first list is a prefix of the second with case-insensitive --- comparison. - -isPrefixOfI :: String -> String -> Bool -isPrefixOfI [] _ = True -isPrefixOfI _ [] = False -isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys 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,311 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Text.Megaparsec.ErrorSpec (spec) where - -import Data.ByteString (ByteString) -import Data.Char (isControl, isSpace) -import Data.List (isInfixOf, isSuffixOf) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Void -import Data.Word (Word8) -import Test.Hspec -import Test.Hspec.Megaparsec.AdHoc () -import Test.QuickCheck -import Text.Megaparsec.Error -import Text.Megaparsec.Error.Builder -import Text.Megaparsec.Pos -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as S -import qualified Data.Set as E - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable, all) -import Prelude hiding (all) -#else -import Control.Exception (Exception (..)) -#endif -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif - -type PE = ParseError Char Void -type PW = ParseError Word8 Void - -spec :: Spec -spec = do - - describe "Semigroup instance of ParseError" $ - it "associativity" $ - property $ \x y z -> - (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE) - - describe "Monoid instance of ParseError" $ do - it "left identity" $ - property $ \x -> - mempty <> x === (x :: PE) - it "right identity" $ - property $ \x -> - x <> mempty === (x :: PE) - it "associativity" $ - property $ \x y z -> - (x <> y) <> z === (x <> (y <> z) :: PE) - - describe "Read and Show instances of ParseError" $ - it "printed representation of ParseError can be read back" $ - property $ \x -> - read (show x) === (x :: PE) - - describe "error merging with (<>)" $ do - it "selects greater source position" $ - property $ \x y -> - errorPos (x <> y :: PE) === max (errorPos x) (errorPos y) - context "when combining two trivial parse errors at the same position" $ - it "merges their unexpected and expected items" $ do - let n Nothing Nothing = Nothing - n (Just x) Nothing = Just x - n Nothing (Just y) = Just y - n (Just x) (Just y) = Just (max x y) - property $ \pos us0 ps0 us1 ps1 -> - TrivialError pos us0 ps0 <> TrivialError pos us1 ps1 `shouldBe` - (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE) - context "when combining two fancy parse errors at the same position" $ - it "merges their custom items" $ - property $ \pos xs0 xs1 -> - FancyError pos xs0 <> FancyError pos xs1 `shouldBe` - (FancyError pos (E.union xs0 xs1) :: PE) - context "when combining trivial error with fancy error" $ do - it "fancy has precedence (left)" $ - property $ \pos us ps xs -> - FancyError pos xs <> TrivialError pos us ps `shouldBe` - (FancyError pos xs :: PE) - it "fancy has precedence (right)" $ - property $ \pos us ps xs -> - TrivialError pos us ps <> FancyError pos xs `shouldBe` - (FancyError pos xs :: PE) - - describe "errorPos" $ - it "returns error position" $ - property $ \e -> - errorPos e `shouldBe` - (case e :: PE of - TrivialError pos _ _ -> pos - FancyError pos _ -> pos) - - describe "showTokens (Char instance)" $ do - let f :: String -> String -> Expectation - f x y = showTokens (NE.fromList x) `shouldBe` y - it "shows CRLF newline correctly" - (f "\r\n" "crlf newline") - it "shows null byte correctly" - (f "\NUL" "null") - it "shows start of heading correctly" - (f "\SOH" "start of heading") - it "shows start of text correctly" - (f "\STX" "start of text") - it "shows end of text correctly" - (f "\ETX" "end of text") - it "shows end of transmission correctly" - (f "\EOT" "end of transmission") - it "shows enquiry correctly" - (f "\ENQ" "enquiry") - it "shows acknowledge correctly" - (f "\ACK" "acknowledge") - it "shows bell correctly" - (f "\BEL" "bell") - it "shows backspace correctly" - (f "\BS" "backspace") - it "shows tab correctly" - (f "\t" "tab") - it "shows newline correctly" - (f "\n" "newline") - it "shows vertical tab correctly" - (f "\v" "vertical tab") - it "shows form feed correctly" - (f "\f" "form feed") - it "shows carriage return correctly" - (f "\r" "carriage return") - it "shows shift out correctly" - (f "\SO" "shift out") - it "shows shift in correctly" - (f "\SI" "shift in") - it "shows data link escape correctly" - (f "\DLE" "data link escape") - it "shows device control one correctly" - (f "\DC1" "device control one") - it "shows device control two correctly" - (f "\DC2" "device control two") - it "shows device control three correctly" - (f "\DC3" "device control three") - it "shows device control four correctly" - (f "\DC4" "device control four") - it "shows negative acknowledge correctly" - (f "\NAK" "negative acknowledge") - it "shows synchronous idle correctly" - (f "\SYN" "synchronous idle") - it "shows end of transmission block correctly" - (f "\ETB" "end of transmission block") - it "shows cancel correctly" - (f "\CAN" "cancel") - it "shows end of medium correctly" - (f "\EM" "end of medium") - it "shows substitute correctly" - (f "\SUB" "substitute") - it "shows escape correctly" - (f "\ESC" "escape") - it "shows file separator correctly" - (f "\FS" "file separator") - it "shows group separator correctly" - (f "\GS" "group separator") - it "shows record separator correctly" - (f "\RS" "record separator") - it "shows unit separator correctly" - (f "\US" "unit separator") - it "shows delete correctly" - (f "\DEL" "delete") - it "shows space correctly" - (f " " "space") - it "shows non-breaking space correctly" - (f "\160" "non-breaking space") - it "shows other single characters in single quotes" $ - property $ \ch -> - not (isControl ch) && not (isSpace ch) ==> - showTokens (ch :| []) === "\'" <> [ch] <> "\'" - it "shows strings in double quotes" $ - property $ \str' -> - let str = filter (not . g) str' - g x = isControl x || x `elem` ['\160'] - in length str > 1 ==> - showTokens (NE.fromList str) === ("\"" <> str <> "\"") - it "shows control characters in long strings property" - (f "{\n" "\"{\"") - - describe "showTokens (Word8 instance)" $ - it "basically works" $ do - -- NOTE Currently the Word8 instance is defined via Char intance, so - -- the testing is rather shallow. - let ts = NE.fromList [10,48,49,50] :: NonEmpty Word8 - showTokens ts `shouldBe` "\"012\"" - - describe "parseErrorPretty" $ do - it "shows unknown ParseError correctly" $ - parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n" - it "result always ends with a newline" $ - property $ \x -> - parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`) - it "result contains representation of source pos stack" $ - property (contains errorPos sourcePosPretty) - it "result contains representation of unexpected items" $ do - let f (TrivialError _ us _) = us - f _ = Nothing - property (contains f showErrorComponent) - it "result contains representation of expected items" $ do - let f (TrivialError _ _ ps) = ps - f _ = E.empty - property (contains f showErrorComponent) - it "result contains representation of custom items" $ do - let f (FancyError _ xs) = xs - f _ = E.empty - property (contains f showErrorComponent) - it "several fancy errors look not so bad" $ do - let pe :: PE - pe = errFancy posI $ - mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar") - parseErrorPretty pe `shouldBe` "1:1:\nbar\nfoo\n" - - describe "parseErrorPretty'" $ do - context "with Char tokens" $ do - it "shows empty line correctly" $ do - let s = "" :: String - parseErrorPretty' s (mempty :: PE) `shouldBe` - "1:1:\n |\n1 | \n | ^\nunknown parse error\n" - it "shows position on first line correctly" $ do - let s = "abc" :: String - pe = err (posN 1 s) (utok 'b' <> etok 'd') :: PE - parseErrorPretty' s pe `shouldBe` - "1:2:\n |\n1 | abc\n | ^\nunexpected 'b'\nexpecting 'd'\n" - it "skips to second line correctly" $ do - let s = "one\ntwo\n" :: String - pe = err (posN 4 s) (utok 't' <> etok 'x') :: PE - parseErrorPretty' s pe `shouldBe` - "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n" - it "shows position on 1000 line correctly" $ do - let s = replicate 999 '\n' ++ "abc" - pe = err (posN 999 s) (utok 'a' <> etok 'd') :: PE - parseErrorPretty' s pe `shouldBe` - "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n" - it "shows offending line in the presence of tabs correctly" $ do - let s = "\tsomething" :: String - pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE - parseErrorPretty' s pe `shouldBe` - "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n" - context "with Word8 tokens" $ do - it "shows empty line correctly" $ do - let s = "" :: ByteString - parseErrorPretty' s (mempty :: PW) `shouldBe` - "1:1:\n |\n1 | \n | ^\nunknown parse error\n" - it "shows position on first line correctly" $ do - let s = "abc" :: ByteString - pe = err (posN 1 s) (utok 98 <> etok 100) :: PW - parseErrorPretty' s pe `shouldBe` - "1:2:\n |\n1 | abc\n | ^\nunexpected 'b'\nexpecting 'd'\n" - it "skips to second line correctly" $ do - let s = "one\ntwo\n" :: ByteString - pe = err (posN 4 s) (utok 116 <> etok 120) :: PW - parseErrorPretty' s pe `shouldBe` - "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n" - it "shows position on 1000 line correctly" $ do - let s = B.replicate 999 10 <> "abc" - pe = err (posN 999 s) (utok 97 <> etok 100) :: PW - parseErrorPretty' s pe `shouldBe` - "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n" - it "shows offending line in the presence of tabs correctly" $ do - let s = "\tsomething" :: ByteString - pe = err (posN 1 s) (utok 115 <> etok 120) :: PW - parseErrorPretty' s pe `shouldBe` - "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n" - - describe "parseErrorPretty_" $ - it "takes tab width into account correctly" $ - property $ \w' -> do - let s = "\tsomething\t" :: String - pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE - w = unPos w' - parseErrorPretty_ w' s pe `shouldBe` - ("1:9:\n |\n1 | " ++ replicate w ' ' ++ "something" ++ replicate w ' ' - ++ "\n | ^\nunexpected 's'\nexpecting 'x'\n") - - describe "sourcePosStackPretty" $ - it "result never ends with a newline " $ - property $ \x -> - let pos = errorPos (x :: PE) - in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`) - - describe "parseErrorTextPretty" $ do - it "shows trivial unknown ParseError correctly" $ - parseErrorTextPretty (mempty :: PE) - `shouldBe` "unknown parse error\n" - it "shows fancy unknown ParseError correctly" $ - parseErrorTextPretty (FancyError posI E.empty :: PE) - `shouldBe` "unknown fancy parse error\n" - it "result always ends with a newline" $ - property $ \x -> - parseErrorTextPretty (x :: PE) - `shouldSatisfy` ("\n" `isSuffixOf`) - -#if MIN_VERSION_base(4,8,0) - describe "displayException" $ - it "produces the same result as parseErrorPretty" $ - property $ \x -> - displayException x `shouldBe` parseErrorPretty (x :: PE) -#endif - ----------------------------------------------------------------------------- --- Helpers - -contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property -contains g r e = property (all f (g e)) - where - rendered = parseErrorPretty e - f x = r x `isInfixOf` rendered 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 Data.Monoid ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import Text.Megaparsec.Char -import Text.Megaparsec.Expr - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif - -spec :: Spec -spec = - describe "makeExprParser" $ do - context "when given valid rendered AST" $ - it "can parse it back" $ - property $ \node -> do - let s = showNode node - prs expr s `shouldParse` node - prs' expr s `succeedsLeaving` "" - context "when stream in empty" $ - it "signals correct parse error" $ - prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term") - context "when term is missing" $ - it "signals correct parse error" $ do - let p = expr <* eof - prs p "-" `shouldFailWith` err (posN 1 "-") (ueof <> elabel "term") - prs p "(" `shouldFailWith` err (posN 1 "(") (ueof <> elabel "term") - prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term") - context "operator is missing" $ - it "signals correct parse error" $ - property $ \a b -> do - let p = expr <* eof - a' = inParens a - n = length a' + 1 - s = a' ++ " " ++ inParens b - c = s !! n - if c == '-' - then prs p s `shouldParse` Sub a b - else prs p s `shouldFailWith` - err (posN n s) (utok c <> eeof <> elabel "operator") - --- Algebraic structures to build abstract syntax tree of our expression. - -data Node - = Val Integer -- ^ literal value - | Neg Node -- ^ negation (prefix unary) - | Fac Node -- ^ factorial (postfix unary) - | Mod Node Node -- ^ modulo - | Sum Node Node -- ^ summation (addition) - | Sub Node Node -- ^ subtraction - | Pro Node Node -- ^ product - | Div Node Node -- ^ division - | Exp Node Node -- ^ exponentiation - deriving (Eq, Show) - -instance Enum Node where - fromEnum (Val _) = 0 - fromEnum (Neg _) = 0 - fromEnum (Fac _) = 0 - fromEnum (Mod _ _) = 0 - fromEnum (Exp _ _) = 1 - fromEnum (Pro _ _) = 2 - fromEnum (Div _ _) = 2 - fromEnum (Sum _ _) = 3 - fromEnum (Sub _ _) = 3 - toEnum _ = error "Oops!" - -instance Ord Node where - x `compare` y = fromEnum x `compare` fromEnum y - -showNode :: Node -> String -showNode (Val x) = show x -showNode n@(Neg x) = "-" ++ showGT n x -showNode n@(Fac x) = showGT n x ++ "!" -showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y -showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y -showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y -showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y -showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y -showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y - -showGT :: Node -> Node -> String -showGT parent node = (if node > parent then showCmp else showNode) node - -showGE :: Node -> Node -> String -showGE parent node = (if node >= parent then showCmp else showNode) node - -showCmp :: Node -> String -showCmp node = (if fromEnum node == 0 then showNode else inParens) node - -inParens :: Node -> String -inParens x = "(" ++ showNode x ++ ")" - -instance Arbitrary Node where - arbitrary = sized arbitraryN0 - -arbitraryN0 :: Int -> Gen Node -arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf) - , (9, arbitraryN1 n) ] - where - leaf = arbitraryN1 (n `div` 2) - -arbitraryN1 :: Int -> Gen Node -arbitraryN1 n = - frequency [ (1, Neg <$> arbitraryN2 n) - , (1, Fac <$> arbitraryN2 n) - , (7, arbitraryN2 n)] - -arbitraryN2 :: Int -> Gen Node -arbitraryN2 0 = Val . getNonNegative <$> arbitrary -arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf - where - leaf = arbitraryN0 (n `div` 2) - --- Some helpers are put here since we don't want to depend on --- "Text.Megaparsec.Lexer". - -lexeme :: Parser a -> Parser a -lexeme p = p <* hidden space - -symbol :: String -> Parser String -symbol = lexeme . string - -parens :: Parser a -> Parser a -parens = between (symbol "(") (symbol ")") - -integer :: Parser Integer -integer = lexeme (read <$> some digitChar "integer") - --- Here we use a table of operators that makes use of all features of --- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex --- but valid expressions and render them to get their textual --- representation. - -expr :: Parser Node -expr = makeExprParser term table - -term :: Parser Node -term = parens expr <|> (Val <$> integer) "term" - -table :: [[Operator Parser Node]] -table = - [ [ Prefix (Neg <$ symbol "-") - , Postfix (Fac <$ symbol "!") - , InfixN (Mod <$ symbol "%") ] - , [ InfixR (Exp <$ symbol "^") ] - , [ InfixL (Pro <$ symbol "*") - , InfixL (Div <$ symbol "/") ] - , [ InfixL (Sum <$ symbol "+") - , InfixL (Sub <$ symbol "-")] ] 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,101 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module Text.Megaparsec.PermSpec (spec) where - -import Control.Applicative -import Data.List (nub, elemIndices) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec.Char -import Text.Megaparsec.Char.Lexer (decimal) -import Text.Megaparsec.Perm - -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif - -data CharRows = CharRows - { getChars :: (Char, Char, Char) - , getInput :: String } - deriving (Eq, Show) - -instance Arbitrary CharRows where - arbitrary = do - chars@(a,b,c) <- arbitrary `suchThat` different - an <- arbitrary - bn <- arbitrary - cn <- arbitrary - input <- concat <$> shuffle - [ replicate an a - , replicate bn b - , replicate cn c] - return $ CharRows chars input - where different (a,b,c) = let l = [a,b,c] in l == nub l - -spec :: Spec -spec = do - - describe "(<$$>)" $ do - context "when supplied parser succeeds" $ - it "returns value returned by the parser" $ - property $ \n -> do - let p = makePermParser (succ <$$> pure (n :: Integer)) - prs p "" `shouldParse` succ n - context "when supplied parser fails" $ - it "signals correct parse error" $ do - let p = makePermParser (succ <$$> decimal) :: Parser Integer - prs p "" `shouldFailWith` err posI (ueof <> elabel "integer") - - describe "(<$?>)" $ do - context "when supplied parser succeeds" $ - it "returns value returned by the parser" $ - property $ \n m -> do - let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer))) - prs p "" `shouldParse` succ m - context "when supplied parser fails" $ - it "returns the default value" $ - property $ \n -> do - let p = makePermParser (succ <$?> (n :: Integer, fail "foo")) - prs p "" `shouldParse` succ n - context "when stream in empty" $ - it "returns the default value" $ - property $ \n -> do - let p = makePermParser (succ <$?> (n :: Integer, decimal)) - prs p "" `shouldParse` succ n - - describe "makeExprParser" $ - it "works" $ - property $ \a' c' v -> do - let (a,b,c) = getChars v - p = makePermParser - ((,,) <$?> (a' :: String, some (char a)) - <||> char b - <|?> (c', char c)) - bis = elemIndices b s - preb = take (bis !! 1) s - cis = elemIndices c s - prec = take (cis !! 1) s - s = getInput v - if | length bis > 1 && (length cis <= 1 || head bis < head cis) -> - prs_ p s `shouldFailWith` err (posN (bis !! 1) s) - ( utok b <> eeof <> - (if a `elem` preb then mempty else etok a) <> - (if c `elem` preb then mempty else etok c) ) - | length cis > 1 -> - prs_ p s `shouldFailWith` err (posN (cis !! 1) s) - ( utok c <> - (if a `elem` prec then mempty else etok a) <> - (if b `elem` prec then eeof else etok b) ) - | b `notElem` s -> - prs_ p s `shouldFailWith` err (posN (length s) s) - ( ueof <> etok b <> - (if a `notElem` s || last s == a then etok a else mempty) <> - (if c `elem` s then mempty else etok c) ) - | otherwise -> - prs_ p s `shouldParse` - ( if a `elem` s then filter (== a) s else a' - , b - , if c `elem` s then c else c' ) 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,63 +0,0 @@ -module Text.Megaparsec.PosSpec (spec) where - -import Control.Exception (evaluate) -import Data.Function (on) -import Data.List (isInfixOf) -import Data.Semigroup ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec.AdHoc () -import Test.QuickCheck -import Text.Megaparsec.Pos - -spec :: Spec -spec = do - - describe "mkPos" $ do - context "when the argument is a non-positive number" $ - it "throws InvalidPosException" $ - property $ \n -> n <= 0 ==> - evaluate (mkPos n) `shouldThrow` (== InvalidPosException n) - context "when the argument is not 0" $ - it "returns Pos with the given value" $ - property $ \n -> - (n > 0) ==> (unPos (mkPos n) `shouldBe` n) - - describe "Read and Show instances of Pos" $ - it "printed representation of Pos is isomorphic to its value" $ - property $ \x -> - read (show x) === (x :: Pos) - - describe "Ord instance of Pos" $ - it "works just like Ord instance of underlying Word" $ - property $ \x y -> - compare x y === (compare `on` unPos) x y - - describe "Semigroup instance of Pos" $ - it "works like addition" $ - property $ \x y -> - x <> y === mkPos (unPos x + unPos y) .&&. - unPos (x <> y) === unPos x + unPos y - - describe "initialPos" $ - it "constructs initial position correctly" $ - property $ \path -> - let x = initialPos path - in sourceName x === path .&&. - sourceLine x === mkPos 1 .&&. - sourceColumn x === mkPos 1 - - describe "Read and Show instances of SourcePos" $ - it "printed representation of SourcePos in isomorphic to its value" $ - property $ \x -> - read (show x) === (x :: SourcePos) - - describe "sourcePosPretty" $ do - it "displays file name" $ - property $ \x -> - sourceName x `isInfixOf` sourcePosPretty x - it "displays line number" $ - property $ \x -> - (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x - it "displays column number" $ - property $ \x -> - (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x diff --git a/tests/Text/Megaparsec/StreamSpec.hs b/tests/Text/Megaparsec/StreamSpec.hs deleted file mode 100644 --- a/tests/Text/Megaparsec/StreamSpec.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.Megaparsec.StreamSpec (spec) where - -import Data.Char (isLetter, chr) -import Data.Proxy -import Data.Semigroup ((<>)) -import Test.Hspec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck -import Text.Megaparsec -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -spec :: Spec -spec = do - - describe "String instance of Stream" $ do - describe "tokenToChunk" $ - it "produces the same result as singleton with tokensToChunk" $ - property $ \ch -> - tokenToChunk sproxy ch === tokensToChunk sproxy [ch] - describe "tokensToChunk" $ - it "list of tokens is isomorphic to chunk" $ - property $ \ts -> - chunkToTokens sproxy (tokensToChunk sproxy ts) === ts - describe "chunkToTokens" $ - it "chunk is isomorphic to list of tokens" $ - property $ \chunk -> - tokensToChunk sproxy (chunkToTokens sproxy chunk) === chunk - describe "chunkLength" $ - it "returns correct length of given chunk" $ - property $ \chunk -> - chunkLength sproxy chunk === length chunk - describe "chunkEmpty" $ - it "only true when chunkLength returns 0" $ - property $ \chunk -> - chunkEmpty sproxy chunk === (chunkLength sproxy chunk <= 0) - describe "positionAt1" $ - it "just returns the given position" $ - property $ \pos t -> - positionAt1 sproxy pos t === pos - describe "positionAtN" $ - it "just returns the given position" $ - property $ \pos chunk -> - positionAtN sproxy pos chunk === pos - describe "advance1" $ do - context "when given newline" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l _) -> - advance1 sproxy w pos '\n' === SourcePos n (l <> pos1) pos1 - context "when given tab" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l c) -> - advance1 sproxy w pos '\t' === SourcePos n l (toNextTab w c) - context "when given other character" $ - it "works correctly" $ - property $ \ch w pos@(SourcePos n l c) -> - (ch /= '\n' && ch /= '\t') ==> - advance1 sproxy w pos ch === SourcePos n l (c <> pos1) - describe "advanceN" $ - it "works correctly" $ - advanceN sproxy defaultTabWidth (initialPos "") "something\n\tfoo" - === SourcePos "" (mkPos 2) (mkPos 12) - describe "take1_" $ do - context "when input in empty" $ - it "returns Nothing" $ - take1_ ("" :: String) === Nothing - context "when input is not empty" $ - it "unconses a token" $ - property $ \s -> not (null s) ==> - take1_ (s :: String) === Just (head s, tail s) - describe "takeN_" $ do - context "requested length is 0" $ - it "returns Just empty chunk and original stream" $ - property $ \s -> - takeN_ 0 (s :: String) === Just ("", s) - context "requested length is greater than 0" $ do - context "stream is empty" $ - it "returns Nothing" $ - property $ \(Positive n) -> - takeN_ n ("" :: String) === Nothing - context "stream is not empty" $ - it "returns a chunk of correct length and rest of the stream" $ - property $ \(Positive n) s -> not (null s) ==> - takeN_ n (s :: String) === Just (splitAt n s) - describe "takeWhile_" $ - it "extracts a chunk that is a prefix consisting of matching tokens" $ - property $ \s -> - takeWhile_ isLetter s === span isLetter s - - describe "ByteString instance of Stream" $ do - describe "tokenToChunk" $ - it "produces the same result as singleton with tokensToChunk" $ - property $ \ch -> - tokenToChunk bproxy ch === tokensToChunk bproxy [ch] - describe "tokensToChunk" $ - it "list of tokens is isomorphic to chunk" $ - property $ \ts -> - chunkToTokens bproxy (tokensToChunk bproxy ts) === ts - describe "chunkToTokens" $ - it "chunk is isomorphic to list of tokens" $ - property $ \chunk -> - tokensToChunk bproxy (chunkToTokens bproxy chunk) === chunk - describe "chunkLength" $ - it "returns correct length of given chunk" $ - property $ \chunk -> - chunkLength bproxy chunk === B.length chunk - describe "chunkEmpty" $ - it "only true when chunkLength returns 0" $ - property $ \chunk -> - chunkEmpty bproxy chunk === (chunkLength bproxy chunk <= 0) - describe "positionAt1" $ - it "just returns the given position" $ - property $ \pos t -> - positionAt1 bproxy pos t === pos - describe "positionAtN" $ - it "just returns the given position" $ - property $ \pos chunk -> - positionAtN bproxy pos chunk === pos - describe "advance1" $ do - context "when given newline" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l _) -> - advance1 bproxy w pos 10 === SourcePos n (l <> pos1) pos1 - context "when given tab" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l c) -> - advance1 bproxy w pos 9 === SourcePos n l (toNextTab w c) - context "when given other character" $ - it "works correctly" $ - property $ \ch w pos@(SourcePos n l c) -> - (ch /= 10 && ch /= 9) ==> - advance1 bproxy w pos ch === SourcePos n l (c <> pos1) - describe "advanceN" $ - it "works correctly" $ - advanceN bproxy defaultTabWidth (initialPos "") "something\n\tfoo" - === SourcePos "" (mkPos 2) (mkPos 12) - describe "take1_" $ do - context "when input in empty" $ - it "returns Nothing" $ - take1_ ("" :: B.ByteString) === Nothing - context "when input is not empty" $ - it "unconses a token" $ - property $ \s -> not (B.null s) ==> - take1_ (s :: B.ByteString) === B.uncons s - describe "takeN_" $ do - context "requested length is 0" $ - it "returns Just empty chunk and original stream" $ - property $ \s -> - takeN_ 0 (s :: B.ByteString) === Just ("", s) - context "requested length is greater than 0" $ do - context "stream is empty" $ - it "returns Nothing" $ - property $ \(Positive n) -> - takeN_ n ("" :: B.ByteString) === Nothing - context "stream is not empty" $ - it "returns a chunk of correct length and rest of the stream" $ - property $ \(Positive n) s -> not (B.null s) ==> - takeN_ n (s :: B.ByteString) === Just (B.splitAt n s) - describe "takeWhile_" $ - it "extracts a chunk that is a prefix consisting of matching tokens" $ - property $ \s -> - let f = isLetter . chr . fromIntegral - in takeWhile_ f s === B.span f s - - describe "Lazy ByteString instance of Stream" $ do - describe "tokenToChunk" $ - it "produces the same result as singleton with tokensToChunk" $ - property $ \ch -> - tokenToChunk blproxy ch === tokensToChunk blproxy [ch] - describe "tokensToChunk" $ - it "list of tokens is isomorphic to chunk" $ - property $ \ts -> - chunkToTokens blproxy (tokensToChunk blproxy ts) === ts - describe "chunkToTokens" $ - it "chunk is isomorphic to list of tokens" $ - property $ \chunk -> - tokensToChunk blproxy (chunkToTokens blproxy chunk) === chunk - describe "chunkLength" $ - it "returns correct length of given chunk" $ - property $ \chunk -> - chunkLength blproxy chunk === fromIntegral (BL.length chunk) - describe "chunkEmpty" $ - it "only true when chunkLength returns 0" $ - property $ \chunk -> - chunkEmpty blproxy chunk === (chunkLength blproxy chunk <= 0) - describe "positionAt1" $ - it "just returns the given position" $ - property $ \pos t -> - positionAt1 blproxy pos t === pos - describe "positionAtN" $ - it "just returns the given position" $ - property $ \pos chunk -> - positionAtN blproxy pos chunk === pos - describe "advance1" $ do - context "when given newline" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l _) -> - advance1 blproxy w pos 10 === SourcePos n (l <> pos1) pos1 - context "when given tab" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l c) -> - advance1 blproxy w pos 9 === SourcePos n l (toNextTab w c) - context "when given other character" $ - it "works correctly" $ - property $ \ch w pos@(SourcePos n l c) -> - (ch /= 10 && ch /= 9) ==> - advance1 blproxy w pos ch === SourcePos n l (c <> pos1) - describe "advanceN" $ - it "works correctly" $ - advanceN blproxy defaultTabWidth (initialPos "") "something\n\tfoo" - === SourcePos "" (mkPos 2) (mkPos 12) - describe "take1_" $ do - context "when input in empty" $ - it "returns Nothing" $ - take1_ ("" :: BL.ByteString) === Nothing - context "when input is not empty" $ - it "unconses a token" $ - property $ \s -> not (BL.null s) ==> - take1_ (s :: BL.ByteString) === BL.uncons s - describe "takeN_" $ do - context "requested length is 0" $ - it "returns Just empty chunk and original stream" $ - property $ \s -> - takeN_ 0 (s :: BL.ByteString) === Just ("", s) - context "requested length is greater than 0" $ do - context "stream is empty" $ - it "returns Nothing" $ - property $ \(Positive n) -> - takeN_ n ("" :: BL.ByteString) === Nothing - context "stream is not empty" $ - it "returns a chunk of correct length and rest of the stream" $ - property $ \(Positive n) s -> not (BL.null s) ==> - takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s) - describe "takeWhile_" $ - it "extracts a chunk that is a prefix consisting of matching tokens" $ - property $ \s -> - let f = isLetter . chr . fromIntegral - in takeWhile_ f s === BL.span f s - - describe "Text instance of Stream" $ do - describe "tokenToChunk" $ - it "produces the same result as singleton with tokensToChunk" $ - property $ \ch -> - tokenToChunk tproxy ch === tokensToChunk tproxy [ch] - describe "tokensToChunk" $ - it "list of tokens is isomorphic to chunk" $ - property $ \ts -> - chunkToTokens tproxy (tokensToChunk tproxy ts) === ts - describe "chunkToTokens" $ - it "chunk is isomorphic to list of tokens" $ - property $ \chunk -> - tokensToChunk tproxy (chunkToTokens tproxy chunk) === chunk - describe "chunkLength" $ - it "returns correct length of given chunk" $ - property $ \chunk -> - chunkLength tproxy chunk === T.length chunk - describe "chunkEmpty" $ - it "only true when chunkLength returns 0" $ - property $ \chunk -> - chunkEmpty tproxy chunk === (chunkLength tproxy chunk <= 0) - describe "positionAt1" $ - it "just returns the given position" $ - property $ \pos t -> - positionAt1 tproxy pos t === pos - describe "positionAtN" $ - it "just returns the given position" $ - property $ \pos chunk -> - positionAtN tproxy pos chunk === pos - describe "advance1" $ do - context "when given newline" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l _) -> - advance1 tproxy w pos '\n' === SourcePos n (l <> pos1) pos1 - context "when given tab" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l c) -> - advance1 tproxy w pos '\t' === SourcePos n l (toNextTab w c) - context "when given other character" $ - it "works correctly" $ - property $ \ch w pos@(SourcePos n l c) -> - (ch /= '\n' && ch /= '\t') ==> - advance1 tproxy w pos ch === SourcePos n l (c <> pos1) - describe "advanceN" $ - it "works correctly" $ - advanceN tproxy defaultTabWidth (initialPos "") "something\n\tfoo" - === SourcePos "" (mkPos 2) (mkPos 12) - describe "take1_" $ do - context "when input in empty" $ - it "returns Nothing" $ - take1_ ("" :: T.Text) === Nothing - context "when input is not empty" $ - it "unconses a token" $ - property $ \s -> not (T.null s) ==> - take1_ (s :: T.Text) === T.uncons s - describe "takeN_" $ do - context "requested length is 0" $ - it "returns Just empty chunk and original stream" $ - property $ \s -> - takeN_ 0 (s :: T.Text) === Just ("", s) - context "requested length is greater than 0" $ do - context "stream is empty" $ - it "returns Nothing" $ - property $ \(Positive n) -> - takeN_ n ("" :: T.Text) === Nothing - context "stream is not empty" $ - it "returns a chunk of correct length and rest of the stream" $ - property $ \(Positive n) s -> not (T.null s) ==> - takeN_ n (s :: T.Text) === Just (T.splitAt n s) - describe "takeWhile_" $ - it "extracts a chunk that is a prefix consisting of matching tokens" $ - property $ \s -> - takeWhile_ isLetter s === T.span isLetter s - - describe "Lazy Text instance of Stream" $ do - describe "tokenToChunk" $ - it "produces the same result as singleton with tokensToChunk" $ - property $ \ch -> - tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch] - describe "tokensToChunk" $ - it "list of tokens is isomorphic to chunk" $ - property $ \ts -> - chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts - describe "chunkToTokens" $ - it "chunk is isomorphic to list of tokens" $ - property $ \chunk -> - tokensToChunk tlproxy (chunkToTokens tlproxy chunk) === chunk - describe "chunkLength" $ - it "returns correct length of given chunk" $ - property $ \chunk -> - chunkLength tlproxy chunk === fromIntegral (TL.length chunk) - describe "chunkEmpty" $ - it "only true when chunkLength returns 0" $ - property $ \chunk -> - chunkEmpty tlproxy chunk === (chunkLength tlproxy chunk <= 0) - describe "positionAt1" $ - it "just returns the given position" $ - property $ \pos t -> - positionAt1 tlproxy pos t === pos - describe "positionAtN" $ - it "just returns the given position" $ - property $ \pos chunk -> - positionAtN tlproxy pos chunk === pos - describe "advance1" $ do - context "when given newline" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l _) -> - advance1 tlproxy w pos '\n' === SourcePos n (l <> pos1) pos1 - context "when given tab" $ - it "works correctly" $ - property $ \w pos@(SourcePos n l c) -> - advance1 tlproxy w pos '\t' === SourcePos n l (toNextTab w c) - context "when given other character" $ - it "works correctly" $ - property $ \ch w pos@(SourcePos n l c) -> - (ch /= '\n' && ch /= '\t') ==> - advance1 tlproxy w pos ch === SourcePos n l (c <> pos1) - describe "advanceN" $ - it "works correctly" $ - advanceN tlproxy defaultTabWidth (initialPos "") "something\n\tfoo" - === SourcePos "" (mkPos 2) (mkPos 12) - describe "take1_" $ do - context "when input in empty" $ - it "returns Nothing" $ - take1_ ("" :: TL.Text) === Nothing - context "when input is not empty" $ - it "unconses a token" $ - property $ \s -> not (TL.null s) ==> - take1_ (s :: TL.Text) === TL.uncons s - describe "takeN_" $ do - context "requested length is 0" $ - it "returns Just empty chunk and original stream" $ - property $ \s -> - takeN_ 0 (s :: TL.Text) === Just ("", s) - context "requested length is greater than 0" $ do - context "stream is empty" $ - it "returns Nothing" $ - property $ \(Positive n) -> - takeN_ n ("" :: TL.Text) === Nothing - context "stream is not empty" $ - it "returns a chunk of correct length and rest of the stream" $ - property $ \(Positive n) s -> not (TL.null s) ==> - takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s) - describe "takeWhile_" $ - it "extracts a chunk that is a prefix consisting of matching tokens" $ - property $ \s -> - takeWhile_ isLetter s === TL.span isLetter s - ----------------------------------------------------------------------------- --- Helpers - -toNextTab :: Pos -> Pos -> Pos -toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w) - where - w = unPos w' - c = unPos c' - -sproxy :: Proxy String -sproxy = Proxy - -bproxy :: Proxy B.ByteString -bproxy = Proxy - -blproxy :: Proxy BL.ByteString -blproxy = Proxy - -tproxy :: Proxy T.Text -tproxy = Proxy - -tlproxy :: Proxy TL.Text -tlproxy = Proxy diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs deleted file mode 100644 --- a/tests/Text/MegaparsecSpec.hs +++ /dev/null @@ -1,1838 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Text.MegaparsecSpec (spec) where - -import Control.Monad.Cont -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.Reader -import Data.Char (toUpper, isLetter) -import Data.Foldable (asum, concat) -import Data.Function (on) -import Data.List (isPrefixOf) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, listToMaybe, isJust) -import Data.Monoid -import Data.Proxy -import Data.String -import Data.Void -import Prelude hiding (span, concat) -import Test.Hspec -import Test.Hspec.Megaparsec -import Test.Hspec.Megaparsec.AdHoc -import Test.QuickCheck hiding (label) -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.State.Lazy as L -import qualified Control.Monad.State.Strict as S -import qualified Control.Monad.Writer.Lazy as L -import qualified Control.Monad.Writer.Strict as S -import qualified Data.List as DL -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as G -import qualified Data.Set as E -import qualified Data.Text as T -import qualified Data.ByteString as BS - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative hiding (many, some) -#endif - -#if !MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where - arbitrary = E.fromList <$> arbitrary - shrink = fmap E.fromList . shrink . E.toList -#endif - -spec :: Spec -spec = do - - describe "position in custom stream" $ do - - describe "eof" $ - it "updates position in stream correctly" $ - property $ \st -> (not . null . stateInput) st ==> do - let p = eof :: CustomParser () - h = head (stateInput st) - apos = let (_:|z) = statePos st in spanStart h :| z - runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utok h <> eeof) ) - - describe "token" $ do - context "when input stream is empty" $ - it "signals correct parse error" $ - property $ \st'@State {..} span -> do - let p = pSpan span - st = (st' :: State [Span]) { stateInput = [] } - runParser' p st `shouldBe` - ( st - , Left (err statePos $ ueof <> etok span) ) - context "when head of stream matches" $ - it "updates parser state correctly" $ - property $ \st'@State {..} span -> do - let p = pSpan span - st = st' { stateInput = span : stateInput } - npos = spanEnd span :| NE.tail statePos - runParser' p st `shouldBe` - ( st { statePos = npos - , stateTokensProcessed = stateTokensProcessed + 1 - , stateInput = stateInput } - , Right span ) - context "when head of stream does not match" $ do - let checkIt s span = - let ms = listToMaybe s - in isJust ms && (spanBody <$> ms) /= Just (spanBody span) - it "signals correct parse error" $ - property $ \st@State {..} span -> checkIt stateInput span ==> do - let p = pSpan span - h = head stateInput - apos = spanStart h :| NE.tail statePos - runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utok h <> etok span)) - - describe "tokens" $ - it "updates position in stream correctly" $ - property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do - let p = tokens compareTokens ts :: CustomParser [Span] - compareTokens = (==) `on` fmap spanBody - compareToken = (==) `on` spanBody - il = length . takeWhile id $ zipWith compareToken stateInput ts - tl = length ts - consumed = take il stateInput - (apos, npos) = - let (pos:|z) = statePos - pxy = Proxy :: Proxy [Span] - in ( positionAt1 pxy pos (head stateInput) :| z - , advanceN pxy stateTabWidth pos consumed :| z ) - if | null ts -> runParser' p st `shouldBe` (st, Right []) - | null stateInput -> runParser' p st `shouldBe` - ( st - , Left (err statePos $ ueof <> etoks ts) ) - | il == tl -> runParser' p st `shouldBe` - ( st { statePos = npos - , stateTokensProcessed = stateTokensProcessed + fromIntegral tl - , stateInput = drop tl stateInput } - , Right consumed ) - | otherwise -> runParser' p st `shouldBe` - ( st { statePos = apos } - , Left (err apos $ utoks (take tl stateInput) <> etoks ts) ) - - describe "takeWhileP" $ - it "updates position in stream correctly" $ - property $ \st@State {..} -> do - let p = takeWhileP Nothing (const True) :: CustomParser [Span] - st' = st - { stateInput = [] - , statePos = - case stateInput of - [] -> statePos - xs -> let _:|z = statePos in spanEnd (last xs) :| z - , stateTokensProcessed = - stateTokensProcessed + length stateInput } - runParser' p st `shouldBe` (st', Right stateInput) - - describe "takeWhile1P" $ do - context "when stream is prefixed with matching tokens" $ - it "updates position in stream correctly" $ - property $ \st@State {..} -> not (null stateInput) ==> do - let p = takeWhile1P Nothing (const True) :: CustomParser [Span] - st' = st - { stateInput = [] - , statePos = - case stateInput of - [] -> statePos - xs -> let _:|z = statePos in spanEnd (last xs) :| z - , stateTokensProcessed = - stateTokensProcessed + length stateInput } - runParser' p st `shouldBe` (st', Right stateInput) - context "when stream is not prefixed with at least one matching token" $ - it "updates position in stream correctly" $ - property $ \st@State {..} -> do - let p = takeWhile1P Nothing (const False) :: CustomParser [Span] - fst (runParser' p st) `shouldBe` st - - describe "takeP" $ do - context "when stream has enough tokens" $ - it "updates position in stream correctly" $ - property $ \st@State {..} -> not (null stateInput) ==> do - let p = takeP Nothing (length stateInput) :: CustomParser [Span] - st' = st - { stateInput = [] - , statePos = - case stateInput of - [] -> statePos - xs -> let _:|z = statePos in spanEnd (last xs) :| z - , stateTokensProcessed = - stateTokensProcessed + length stateInput } - runParser' p st `shouldBe` (st', Right stateInput) - context "when stream has not enough tokens" $ - it "updates position in stream correctly" $ - property $ \st@State {..} -> not (null stateInput) ==> do - let p = takeP Nothing (1 + length stateInput) :: CustomParser [Span] - (pos:|z) = statePos - st' = st - { statePos = positionAtN - (Proxy :: Proxy [Span]) pos stateInput :| z } - fst (runParser' p st) `shouldBe` st' - - describe "getNextTokenPosition" $ do - context "when input stream is empty" $ - it "returns Nothing" $ - property $ \st' -> do - let p :: CustomParser (Maybe SourcePos) - p = getNextTokenPosition - st = (st' :: State [Span]) { stateInput = [] } - runParser' p st `shouldBe` (st, Right Nothing) - context "when input stream is not empty" $ - it "return the position of start of the next token" $ - property $ \st' h -> do - let p :: CustomParser (Maybe SourcePos) - p = getNextTokenPosition - st = st' { stateInput = h : stateInput st' } - runParser' p st `shouldBe` (st, (Right . Just . spanStart) h) - - describe "ParsecT Semigroup instance" $ - it "the associative operation works" $ - property $ \a b -> do - let p = pure [a] G.<> pure [b] - prs p "" `shouldParse` ([a,b] :: [Int]) - - describe "ParsecT Monoid instance" $ do - it "mempty works" $ do - let p = mempty - prs p "" `shouldParse` ([] :: [Int]) - it "mappend works" $ - property $ \a b -> do - let p = pure [a] `mappend` pure [b] - prs p "" `shouldParse` ([a,b] :: [Int]) - - describe "ParsecT IsString instance" $ do - describe "equivalence to 'string'" $ do - it "for String" $ property $ \s i -> - eqParser - (string s) - (fromString s) - (i :: String) - it "for Text" $ property $ \s i -> - eqParser - (string (T.pack s)) - (fromString s) - (i :: T.Text) - it "for ByteString" $ property $ \s i -> - eqParser - (string (fromString s :: BS.ByteString)) - (fromString s) - (i :: BS.ByteString) - it "can handle Unicode" $ do - let - r = "פּאַרסער 解析器" :: BS.ByteString - p :: Parsec Void BS.ByteString BS.ByteString - p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"] - parse p "" r `shouldParse` r - - describe "ParsecT Functor instance" $ do - it "obeys identity law" $ - property $ \n -> - prs (fmap id (pure (n :: Int))) "" === - prs (id (pure n)) "" - it "obeys composition law" $ - property $ \n m t -> - let f = (+ m) - g = (* t) - in prs (fmap (f . g) (pure (n :: Int))) "" === - prs ((fmap f . fmap g) (pure n)) "" - - describe "ParsecT Applicative instance" $ do - it "obeys identity law" $ - property $ \n -> - prs (pure id <*> pure (n :: Int)) "" === - prs (pure n) "" - it "obeys composition law" $ - property $ \n m t -> - let u = pure (+ m) - v = pure (* t) - w = pure (n :: Int) - in prs (pure (.) <*> u <*> v <*> w) "" === - prs (u <*> (v <*> w)) "" - it "obeys homomorphism law" $ - property $ \x m -> - let f = (+ m) - in prs (pure f <*> pure (x :: Int)) "" === - prs (pure (f x)) "" - it "obeys interchange law" $ - property $ \n y -> - let u = pure (+ n) - in prs (u <*> pure (y :: Int)) "" === - prs (pure ($ y) <*> u) "" - describe "(<*>)" $ - context "when first parser succeeds without consuming" $ - context "when second parser fails consuming input" $ - it "fails consuming input" $ do - let p = m <*> n - m = return (\x -> 'a' : x) - n = string "bc" <* empty - s = "bc" - prs p s `shouldFailWith` err (posN (4 :: Int) s) mempty - prs' p s `failsLeaving` "" - describe "(*>)" $ - it "works correctly" $ - property $ \n m -> - let u = pure (+ (m :: Int)) - v = pure (n :: Int) - in prs (u *> v) "" === - prs (pure (const id) <*> u <*> v) "" - describe "(<*)" $ - it "works correctly" $ - property $ \n m -> - let u = pure (m :: Int) - v = pure (+ (n :: Int)) - in prs (u <* v) "" === prs (pure const <*> u <*> v) "" - - describe "ParsecT Alternative instance" $ do - - describe "empty" $ - it "always fails" $ - property $ \n -> - prs (empty <|> pure n) "" `shouldParse` (n :: Integer) - - describe "(<|>)" $ do - context "with two strings" $ do - context "stream begins with the first string" $ - it "parses the string" $ - property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do - let s' = s0 ++ s - p = string s0 <|> string s1 - prs p s' `shouldParse` s0 - prs' p s' `succeedsLeaving` s - context "stream begins with the second string" $ - it "parses the string" $ - property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do - let s' = s1 ++ s - p = string s0 <|> string s1 - prs p s' `shouldParse` s1 - prs' p s' `succeedsLeaving` s - context "when stream does not begin with either string" $ - it "signals correct error message" $ - property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do - let p = string s0 <|> string s1 - z = take (max (length s0) (length s1)) s - prs p s `shouldFailWith` err posI - (etoks s0 <> - etoks s1 <> - (if null s then ueof else utoks z)) - context "with two complex parsers" $ do - context "when stream begins with matching character" $ - it "parses it" $ - property $ \a b -> a /= b ==> do - let p = char a <|> (char b *> char a) - s = [a] - prs p s `shouldParse` a - prs' p s `succeedsLeaving` "" - context "when stream begins with only one matching character" $ - it "signals correct parse error" $ - property $ \a b c -> a /= b && a /= c ==> do - let p = char a <|> (char b *> char a) - s = [b,c] - prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a) - prs' p s `failsLeaving` [c] - context "when stream begins with not matching character" $ - it "signals correct parse error" $ - property $ \a b c -> a /= b && a /= c && b /= c ==> do - let p = char a <|> (char b *> char a) - s = [c,b] - prs p s `shouldFailWith` err posI (utok c <> etok a <> etok b) - prs' p s `failsLeaving` s - context "when stream is emtpy" $ - it "signals correct parse error" $ - property $ \a b -> do - let p = char a <|> (char b *> char a) - prs p "" `shouldFailWith` err posI (ueof <> etok a <> etok b) - it "associativity of fold over alternatives should not matter" $ do - let p = asum [empty, string ">>>", empty, return "foo"] "bar" - p' = bsum [empty, string ">>>", empty, return "foo"] "bar" - bsum = foldl (<|>) empty - s = ">>" - prs p s `shouldBe` prs p' s - - describe "many" $ do - context "when stream begins with things argument of many parses" $ - it "they are parsed" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = many (char 'a') - s = abcRow a b c - prs p s `shouldParse` replicate a 'a' - prs' p s `succeedsLeaving` drop a s - context "when stream does not begin with thing argument of many parses" $ - it "does nothing" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = many (char 'd') - s = abcRow a b c - prs p s `shouldParse` "" - prs' p s `succeedsLeaving` s - context "when stream is empty" $ - it "succeeds parsing nothing" $ do - let p = many (char 'a') - prs p "" `shouldParse` "" - context "when there are two many combinators in a row that parse nothing" $ - it "accumulated hints are reflected in parse error" $ do - let p = many (char 'a') *> many (char 'b') *> eof - prs p "c" `shouldFailWith` err posI - (utok 'c' <> etok 'a' <> etok 'b' <> eeof) - context "when the argument parser succeeds without consuming" $ - it "is run nevertheless" $ - property $ \n' -> do - let n = getSmall (getNonNegative n') :: Integer - p = void . many $ do - x <- S.get - if x < n then S.modify (+ 1) else empty - v :: S.State Integer (Either (ParseError Char Void) ()) - v = runParserT p "" ("" :: String) - S.execState v 0 `shouldBe` n - - describe "some" $ do - context "when stream begins with things argument of some parses" $ - it "they are parsed" $ - property $ \a' b' c' -> do - let a = getPositive a' - [b,c] = getNonNegative <$> [b',c'] - p = some (char 'a') - s = abcRow a b c - prs p s `shouldParse` replicate a 'a' - prs' p s `succeedsLeaving` drop a s - context "when stream does not begin with thing argument of some parses" $ - it "signals correct parse error" $ - property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] - p = some (char 'd') - s = abcRow a b c ++ "g" - prs p s `shouldFailWith` err posI (utok (head s) <> etok 'd') - prs' p s `failsLeaving` s - context "when stream is empty" $ - it "signals correct parse error" $ - property $ \ch -> do - let p = some (char ch) - prs p "" `shouldFailWith` err posI (ueof <> etok ch) - context "optional" $ do - context "when stream begins with that optional thing" $ - it "parses it" $ - property $ \a b -> do - let p = optional (char a) <* char b - s = [a,b] - prs p s `shouldParse` Just a - prs' p s `succeedsLeaving` "" - context "when stream does not begin with that optional thing" $ - it "succeeds parsing nothing" $ - property $ \a b -> a /= b ==> do - let p = optional (char a) <* char b - s = [b] - prs p s `shouldParse` Nothing - prs' p s `succeedsLeaving` "" - context "when stream is empty" $ - it "succeeds parsing nothing" $ - property $ \a -> do - let p = optional (char a) - prs p "" `shouldParse` Nothing - - describe "ParsecT Monad instance" $ do - it "satisfies left identity law" $ - property $ \a k' -> do - let k = return . (+ k') - p = return (a :: Int) >>= k - prs p "" `shouldBe` prs (k a) "" - it "satisfies right identity law" $ - property $ \a -> do - let m = return (a :: Int) - p = m >>= return - prs p "" `shouldBe` prs m "" - it "satisfies associativity law" $ - property $ \m' k' h' -> do - let m = return (m' :: Int) - k = return . (+ k') - h = return . (* h') - p = m >>= (\x -> k x >>= h) - p' = (m >>= k) >>= h - prs p "" `shouldBe` prs p' "" - it "fails signals correct parse error" $ - property $ \msg -> do - let p = fail msg :: Parsec Void String () - prs p "" `shouldFailWith` errFancy posI (fancy $ ErrorFail msg) - it "pure is the same as return" $ - property $ \n -> - prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" - it "(<*>) is the same as ap" $ - property $ \m' k' -> do - let m = return (m' :: Int) - k = return (+ k') - prs (k <*> m) "" `shouldBe` prs (k `ap` m) "" - - describe "ParsecT MonadFail instance" $ - describe "fail" $ - it "signals correct parse error" $ - property $ \s msg -> do - let p = void (fail msg) - prs p s `shouldFailWith` errFancy posI (fancy $ ErrorFail msg) - prs' p s `failsLeaving` s - - describe "ParsecT MonadIO instance" $ - it "liftIO works" $ - property $ \n -> do - let p = liftIO (return n) :: ParsecT Void String IO Integer - runParserT p "" "" `shouldReturn` Right n - - describe "ParsecT MonadFix instance" $ - it "withRange works" $ do - let - withRange - :: (MonadParsec e s m, MonadFix m) - => ((SourcePos,SourcePos) -> m a) - -> m a - withRange f = do - Just p1 <- getNextTokenPosition - rec - r <- f (p1, p2) - p2 <- getPosition - return r - p :: Parsec Void String (SourcePos,SourcePos) - p = withRange $ \pp -> pp <$ string "ab" - runParser p "" "abcd" - `shouldBe` Right - ( SourcePos "" (mkPos 1) (mkPos 1) - , SourcePos "" (mkPos 1) (mkPos 3) - ) - - describe "ParsecT MonadReader instance" $ do - - describe "ask" $ - it "returns correct value of context" $ - property $ \n -> do - let p = ask :: ParsecT Void String (Reader Integer) Integer - runReader (runParserT p "" "") n `shouldBe` Right n - - describe "local" $ - it "modifies reader context correctly" $ - property $ \n k -> do - let p = local (+ k) ask :: ParsecT Void String (Reader Integer) Integer - runReader (runParserT p "" "") n `shouldBe` Right (n + k) - - describe "ParsecT MonadState instance" $ do - - describe "get" $ - it "returns correct state value" $ - property $ \n -> do - let p = L.get :: ParsecT Void String (L.State Integer) Integer - L.evalState (runParserT p "" "") n `shouldBe` Right n - describe "put" $ - it "replaces state value" $ - property $ \a b -> do - let p = L.put b :: ParsecT Void String (L.State Integer) () - L.execState (runParserT p "" "") a `shouldBe` b - - describe "ParsecT MonadCont instance" $ - - describe "callCC" $ - it "works properly" $ - property $ \a b -> do - let p :: ParsecT Void String (Cont (Either (ParseError Char Void) Integer)) Integer - p = callCC $ \e -> when (a > b) (e a) >> return b - runCont (runParserT p "" "") id `shouldBe` Right (max a b) - - describe "ParsecT MonadError instance" $ do - - describe "throwError" $ - it "throws the error" $ - property $ \a b -> do - let p :: ParsecT Void String (Except Integer) Integer - p = throwError a >> return b - runExcept (runParserT p "" "") `shouldBe` Left a - - describe "catchError" $ - it "catches the error" $ - property $ \a b -> do - let p :: ParsecT Void String (Except Integer) Integer - p = (throwError a >> return b) `catchError` handler - handler e = return (e + b) - runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b) - - describe "primitive combinators" $ do - - describe "failure" $ - it "signals correct parse error" $ - property $ \us ps -> do - let p :: MonadParsec Void String m => m () - p = void (failure us ps) - grs p "" (`shouldFailWith` TrivialError posI us ps) - - describe "fancyFailure" $ - it "singals correct parse error" $ - property $ \xs -> do - let p :: MonadParsec Void String m => m () - p = void (fancyFailure xs) - grs p "" (`shouldFailWith` FancyError posI xs) - - describe "label" $ do - context "when inner parser succeeds consuming input" $ do - context "inner parser does not produce any hints" $ - it "collection of hints remains empty" $ - property $ \lbl a -> not (null lbl) ==> do - let p :: MonadParsec Void String m => m Char - p = label lbl (char a) <* empty - s = [a] - grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty) - grs' p s (`failsLeaving` "") - context "inner parser produces hints" $ - it "replaces the last hint with “the rest of