packages feed

megaparsec 5.3.1 → 6.0.0

raw patch · 43 files changed

+7780/−5755 lines, 43 filesdep +case-insensitivedep +parser-combinatorsdep +voiddep −exceptionsdep −taggeddep ~base

Dependencies added: case-insensitive, parser-combinators, void

Dependencies removed: exceptions, tagged

Dependency ranges changed: base

Files

AUTHORS.md view
@@ -24,6 +24,7 @@ ## Contributors  * Albert Netymk+* Alex Washburn (@recursion-ninja) * Antoine Latter * Artyom (@neongreen) * Auke Booij
CHANGELOG.md view
@@ -1,3 +1,132 @@+## Megaparsec 6.0.0++### General++* Re-organized the module hierarchy. Some modules such as+  `Text.Megaparsec.Prim` do not exist anymore. Stream definitions were moved+  to `Text.Megaparsec.Stream`. Generic combinators are now re-exported from+  the `Control.Applicative.Combinators` from the package+  `parser-combinators`. Just import `Text.Megaparsec` and you should be OK.+  Add `Text.Megaparsec.Char` if you are working with a stream of `Char`s or+  `Text.Megaparsec.Byte` if you intend to parse binary data, then add+  qualified modules you need (permutation parsing, lexing, expression+  parsing, etc.). `Text.Megaparsec.Lexer` was renamed to+  `Text.Megaparec.Char.Lexer` because many functions in it has the `Token s+  ~ Char` constraint. There is also `Text.Megaparsec.Byte.Lexer` now,+  although it has fewer functions.++* Dropped per-stream modules, the `Parser` type synonym is to be defined+  manually by user.++* Added a `MonadFix` instance for `ParsecT`.++* More lightweight dependency tree, dropped `exceptions` and `QuickCheck`+  dependencies.++* Added dependency on `case-insensitive`.++### Source positions++* Now `Pos` contains an `Int` inside, not `Word`.++* Dropped `unsafePos` and changed type of `mkPos` so it throws from pure+  code if its argument is not a positive `Int`.++* Added `pos1` constant that represents the `Pos` with value 1 inside.++* Made `InvalidPosException` contain the invalid `Int` value that was passed+  to `mkPos`.++### Parse errors++* Changed the definition of `ParseError` to have separate data constructors+  for “trivial” errors (unexpected/expected tokens) and “fancy” errors+  (everything else).++* Removed the `ErrorComponent` type class, added `ErrorFancy` instead.+  `ErrorFancy` is a sum type which can represent `fail` messages, incorrect+  indentation, and custom data (we use `Void` for that by default to+  “disable” it). This is better than the typeclass-based approach because+  every instance of `ErrorComponent` needed to have constructors for `fail`+  and indentation massages anyway, leading to duplication of code (for+  example for parse error component rendering).++* Added `Functor` instances for `ErrorItem` and `ErrorFancy`.++* Added the function `errorPos` to get error positions from `ParseError`+  (previously it was a record selector in `ParseError`).++* Control characters in parse error are displayed in a readable form even+  when they are part of strings, for example: `{<newline>` (`{` followed by+  the newline character). Previously control characters were rendered in+  readable form only as standalone tokens.++* Added `Text.Megaparsec.Error.Builder` module to help construct+  `ParseError`s easily. It is useful for testing and debugging. Previously+  we had something like that in the `hspec-megaparsec` package, but it does+  not hurt to ship it with the library.++* Added `parseErrorPretty'` allowing to display offending line in parse+  errors.++* Added `LineToken` type class for tokens that support operations necessary+  for selecting and displaying relevant line of input (used in+  `parseErrorPretty'`).++* Added `parseTest'` function that is just like `parseTest`, but also prints+  offending line in parse errors. This is powered by the new+  `parseErrorPretty'`.++### Stream++* Introduced the new `Text.Megaparsec.Stream` module that is the home of+  `Stream` type class. In version 6, the type class has been extended+  significantly to improve performance and make some combinators more+  general.++### Combinators++* Changed signatures of `failure` and `token`, they only can signal trivial+  errors now.++* Added a new method of `MonadParsec` type class called `fancyFailure` for+  signalling non-trivial failures. Signatures of some functions (`failure`,+  `token`) have been changed accordingly.++* Added `takeWhileP`, `takeWhile1P` and `takeP` to `MonadParsec`.++* Added `takeRest` non-primitive combinator to consume the rest of input.++* Added `atEnd` which returns `True` when end of input has been reached.++* Dropped `oneOf'` and `noneOf'` from `Text.Megaparsec.Char`. These were+  seldom (if ever) used and are easily re-implemented.++* Added `notChar` in `Text.Megaparsec.Char`.++* Added `space1` in `Text.Megaprasec.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`+  instead.++* `number` was dropped from `Text.Megaparec.Char.Lexer`. Use `scientific`+  instead.++* `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return+  type and can be used to parse any instance of `Integral`.++* `float` is now polymorphic in its return type and can be used to parse any+  instance of `RealFloat`.++* Added new module `Text.Megaparsec.Byte.Lexer`, which provides some+  functions (white space and numeric helpers) from+  `Text.Megaparsec.Char.Lexer` for streams with token type `Word8`.+ ## Megaparsec 5.3.1  * Various updates to the docs.
README.md view
@@ -12,6 +12,7 @@     * [Error messages](#error-messages)     * [Alex and Happy support](#alex-and-happy-support)     * [Character parsing](#character-parsing)+    * [Binary parsing](#binary-parsing)     * [Permutation parsing](#permutation-parsing)     * [Expression parsing](#expression-parsing)     * [Lexer](#lexer)@@ -25,13 +26,14 @@     * [Megaparsec vs Earley](#megaparsec-vs-earley)     * [Megaparsec vs Parsers](#megaparsec-vs-parsers) * [Related packages](#related-packages)-* [Links to announcements](#links-to-announcements)+* [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 fork of [Parsec](https://github.com/aslatter/parsec) library originally+is a fork of [Parsec](https://github.com/haskell/parsec) library originally written by Daan Leijen.  ## Features@@ -54,29 +56,13 @@ most useful ones are `Monad`, `Applicative`, `Alternative`, and `MonadParsec`. -The module-[`Text.Megaparsec.Combinator`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Combinator.html) (its-functions are included in `Text.Megaparsec`) contains traditional, general-combinators that work with instances of `Applicative` and `Alternative`.--Let's enumerate methods of the `MonadParsec` type class. The class abstracts-primitive functions of Megaparsec parsing. The rest of the library is built-via combination of these primitives:--* `failure` allows to fail reporting an arbitrary parse error.--* `label` allows to add a “label” to a parser, so if it fails the user will-  see the label instead of an automatically deduced expected token.--* `hidden` hides a parser from error messages altogether. This is the-  recommended way to hide things, prefer it to the `label ""` approach.--* `try` enables backtracking in parsing.+Megaparsec includes all functionality that is available in Parsec plus+features some combinators that are missing in other parsing libraries: -* `lookAhead` allows to parse input without consuming it.+* `failure` allows to fail reporting a parse error with unexpected and+  expected items. -* `notFollowedBy` succeeds when its argument fails and does not consume-  input.+* `fancyFailure` allows to fail reporting custom error messages.  * `withRecovery` allows to recover from parse errors “on-the-fly” and   continue parsing. Once parsing is finished, several parse errors may be@@ -85,21 +71,24 @@ * `observing` allows to “observe” parse errors without ending parsing (they   are returned in `Left`, while normal results are wrapped in `Right`). -* `eof` only succeeds at the end of input.--* `token` is used to parse a single token.+In addition to that, Megaparsec 6 features high-performance combinators+similar to those found in Attoparsec: -* `tokens` makes it easy to parse several tokens in a row.+* `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. -* `getParserState` returns the full parser state.+* `takeWhile` and `takeWhile1` are about 150 times faster than approaches+  involving `many`, `manyTill` and other similar combinators. -* `updateParserState` applies a given function on the parser state.+* `takeP` allows to grab n tokens from the stream and returns them as a+  “chunk” of the stream. -This list of core functions is longer than in some other libraries. Our goal-is efficient, readable implementations, and rich functionality, not minimal-number of primitive combinators. You can read the comprehensive description-of every primitive function in-[Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html).+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.  Megaparsec can currently work with the following types of input stream out-of-the-box:@@ -117,30 +106,22 @@ custom data types to adjust the library to specific domain of interest. No need to use a shapeless bunch of strings anymore. -The default error component (`Dec`) has constructors corresponding to the-`fail` function and indentation-related error messages. It is a decent-option that should work out-of-box for most parsing needs, while you are-free to use your own custom error component when necessary.--This new design allowed Megaparsec 5 to have much more helpful error-messages for indentation-sensitive parsing instead of the plain “incorrect-indentation” phrase.+The design of parse errors has been revised in version 6 significantly, but+custom errors are still easy (probably even easier now).  ### Alex and Happy support  Megaparsec works well with streams of tokens produced by tools like-Alex/Happy. Megaparsec 5 adds `updatePos` method to `Stream` type class that-gives you full control over textual positions that are used to report token-positions in error messages. You can update current position on per-character basis or extract it from token.+Alex/Happy. 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.  ### Character parsing  Megaparsec has decent support for Unicode-aware character parsing. Functions for character parsing live in the-[`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html)-module (they all are included in `Text.Megaparsec`). The functions can be-divided into several categories:+[`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) module.+The functions can be divided into several categories:  * *Simple parsers*—parsers that parse certain character or several   characters of the same kind. This includes `newline`, `crlf`, `eol`,@@ -159,6 +140,12 @@ * *Parsers for sequences of characters* parse strings. Case-sensitive   `string` parser is available as well as case-insensitive `string'`. +### Binary parsing++Similarly, there is+[`Text.Megaparsec.Byte`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) module+for parsing streams of bytes.+ ### Permutation parsing  For those who are interested in parsing of permutation phrases, there@@ -178,24 +165,27 @@  ### Lexer -[`Text.Megaparsec.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Lexer.html)+[`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.Lexer` is intended to be imported via a qualified import,-it's not included in `Text.Megaparsec`. The module doesn't impose how you-should write your parser, but certain approaches may be more elegant than-others. An especially important theme is parsing of white space, comments,-and indentation.+`Text.Megaparsec.Char.Lexer` is intended to be imported via a qualified+import, it's not included in `Text.Megaparsec`. The module doesn't impose+how you should write your parser, but certain approaches may be more elegant+than others. An especially important theme is parsing of white space,+comments, and indentation.  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.  Since Megaparsec 5, all tools for indentation-sensitive parsing are-available in `Text.Megaparsec.Lexer` module—no third party packages+available in `Text.Megaparsec.Char.Lexer` module—no third party packages required. +`Text.Megaparsec.Byte.Lexer` is also available for users who wish to parse+binary data.+ ## Documentation  Megaparsec is well-documented. All functions and data-types are thoroughly@@ -205,7 +195,8 @@  ## Tutorials -You can find Megaparsec 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@@ -219,6 +210,10 @@ faster. If you happen to have some other benchmarks, I would appreciate if you add Megaparsec to them and let me know how it performs. +Additional benchmarks created to guide development of Megaparsec 6 can be+found [here](https://github.com/mrkkrp/parsers-bench). These compare 3 pairs+of parsers written using Attoparsec and Megaparsec.+ 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). @@ -245,6 +240,11 @@ 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.+ ### Megaparsec vs Parsec  Since Megaparsec is a fork of Parsec, we are bound to list the main@@ -255,6 +255,9 @@   values of our parsers. Megaparsec will be especially useful if you write a   compiler or an interpreter for some language. +* Megaparsec 6 can show 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. @@ -285,28 +288,23 @@   tag”, e.g. we could build a context stack like “in function definition   foo”, “in expression x”, etc. This is not possible with Parsec. -* Megaparsec is faster.--* Megaparsec is ~~better~~ supported.+* Megaparsec is faster and supports efficient operations on top of `tokens`,+  `takeWhileP`, `takeWhile1P`, `takeP` just 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 comparison. -To be honest Parsec's development has seemingly stagnated. It has no test-suite (only three per-bug tests), and all its releases beginning from-version 3.1.2 (according or its change log) were about introducing and-fixing regressions. Parsec is old and somewhat famous in the Haskell-community, so we understand there will be some kind of inertia, but we-advise you use Megaparsec from now on because it solves many problems of the-original Parsec project. If you think you still have a reason to use-original Parsec, open an issue.+Parsec is old and somewhat famous in the Haskell community, so we understand+there will be some kind of inertia, but we advise you use Megaparsec from+now on because it solves many problems of the original Parsec project. If+you think you still have a reason to use original Parsec, open an issue.  ### Megaparsec vs Trifecta  [Trifecta](https://hackage.haskell.org/package/trifecta) is another Haskell-library featuring good error messages. Like some other projects of Edward-Kmett, it's probably good, but also under-documented, and has+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) that Edward is too busy to fix (simply a fact, no offense intended). Other reasons one may question choice of Trifecta is his/her parsing library:@@ -343,9 +341,9 @@   affect any error that happens in those regions, etc.  * The approach Earley uses differs from the conventional monadic parsing. If-  you work not alone, chances people you work with, especially beginners-  will be much more productive with libraries taking more traditional path-  to parsing like Megaparsec.+  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. @@ -355,11 +353,9 @@ which is great. You can use it with Megaparsec or Parsec, but consider the following: -* It depends on Attoparsec, Parsec, and Trifecta, which means you always-  grab half of Hackage as transitive dependencies by using it. This is-  ridiculous, by the way, because this package is supposed to be useful for-  parser builders, so they can write basic core functionality and get the-  rest “for free”.+* It depends on both Attoparsec and Parsec. This is ridiculous, by the way,+  because this package is supposed to be useful for parser builders, so they+  can write basic core functionality and get the rest “for free”.  * It currently has a ~~bug~~ feature in definition of `lookAhead` for   various monad transformers like `StateT`, etc. which is visible when you@@ -381,21 +377,28 @@ * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)—utilities   for testing Megaparsec parsers with   with [Hspec](https://hackage.haskell.org/package/hspec).- * [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec)—Megaparsec   parser of CSV files that plays nicely   with [Cassava](https://hackage.haskell.org/package/cassava).- * [`tagsoup-megaparsec`](https://hackage.haskell.org/package/tagsoup-megaparsec)—a   library for easily   using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token   type in Megaparsec. -## Links to announcements+## Prominent projects that use Megaparsec +* [Hledger](https://github.com/simonmichael/hledger)—an accounting tool+* [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: +* [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)
Text/Megaparsec.hs view
@@ -13,205 +13,1532 @@ -- If you are new to Megaparsec and don't know where to begin, take a look -- at the tutorials <https://markkarpov.com/learn-haskell.html#megaparsec-tutorials>. ----- By default this module is set up to parse character data. If you'd like--- to parse the result of your own tokenizer you should start with the--- following imports:------ > import Text.Megaparsec.Prim--- > import Text.Megaparsec.Combinator------ Then you can implement your own version of 'satisfy' on top of the--- 'token' primitive, etc.------ The typical import section looks like this:------ > import Text.Megaparsec--- > import Text.Megaparsec.String--- > -- import Text.Megaparsec.ByteString--- > -- import Text.Megaparsec.ByteString.Lazy--- > -- import Text.Megaparsec.Text--- > -- import Text.Megaparsec.Text.Lazy------ As you can see the second import depends on the data type you want to use--- as input stream. It just defines the useful type-synonym @Parser@.------ Megaparsec 5 uses some type-level machinery to provide flexibility--- without compromising on type safety. Thus type signatures are sometimes--- necessary to avoid ambiguous types. If you're seeing a error message that--- reads like “Ambiguous type variable @e0@ arising from … prevents the--- constraint @(ErrorComponent e0)@ from being resolved”, you need to give--- an explicit signature to your parser to resolve the ambiguity. It's a--- good idea to provide type signatures for all top-level definitions.------ Megaparsec is capable of a lot. Apart from this standard functionality--- you can parse permutation phrases with "Text.Megaparsec.Perm",--- expressions with "Text.Megaparsec.Expr", and even entire languages with--- "Text.Megaparsec.Lexer". These modules should be imported explicitly--- along with the two modules mentioned above.--module Text.Megaparsec-  ( -- * Running parser-    Parsec-  , ParsecT-  , parse-  , parseMaybe-  , parseTest-  , runParser-  , runParser'-  , runParserT-  , runParserT'-    -- * Combinators-  , (A.<|>)-  -- $assocbo-  , A.many-  -- $many-  , A.some-  -- $some-  , A.optional-  -- $optional-  , unexpected-  , match-  , region-  , failure-  , (<?>)-  , label-  , hidden-  , try-  , lookAhead-  , notFollowedBy-  , withRecovery-  , observing-  , eof-  , token-  , tokens-  , between-  , choice-  , count-  , count'-  , eitherP-  , endBy-  , endBy1-  , manyTill-  , someTill-  , option-  , sepBy-  , sepBy1-  , sepEndBy-  , sepEndBy1-  , skipMany-  , skipSome-    -- * Character parsing-  , newline-  , crlf-  , eol-  , tab-  , space-  , controlChar-  , spaceChar-  , upperChar-  , lowerChar-  , letterChar-  , alphaNumChar-  , printChar-  , digitChar-  , octDigitChar-  , hexDigitChar-  , markChar-  , numberChar-  , punctuationChar-  , symbolChar-  , separatorChar-  , asciiChar-  , latin1Char-  , charCategory-  , char-  , char'-  , anyChar-  , oneOf-  , oneOf'-  , noneOf-  , noneOf'-  , satisfy-  , string-  , string'-    -- * Textual source position-  , Pos-  , mkPos-  , unPos-  , unsafePos-  , InvalidPosException (..)-  , SourcePos (..)-  , initialPos-  , sourcePosPretty-    -- * Error messages-  , ErrorItem (..)-  , ErrorComponent (..)-  , Dec (..)-  , ParseError (..)-  , ShowToken (..)-  , ShowErrorComponent (..)-  , parseErrorPretty-    -- * Debugging-  , dbg-    -- * Low-level operations-  , Stream (..)-  , State (..)-  , getInput-  , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , getParserState-  , setParserState-  , updateParserState )-where--import qualified Control.Applicative as A--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim---- $assocbo------ This combinator implements choice. The parser @p \<|> q@ first applies--- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails--- /without consuming any input/, parser @q@ is tried.------ The parser is called /predictive/ since @q@ is only tried when parser @p@--- didn't consume any input (i.e. the look ahead is 1). This--- non-backtracking behaviour allows for both an efficient implementation of--- the parser combinators and the generation of good error messages.---- $many------ @many p@ applies the parser @p@ /zero/ or more times and returns a list--- of the returned values of @p@. Note that if the @p@ parser fails--- consuming input, then the entire @many p@ parser fails with the error--- message @p@ produced instead of just stopping iterating. In these cases--- wrapping @p@ with 'try' may be desirable.------ > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_')---- $some------ @some p@ applies the parser @p@ /one/ or more times and returns a list of--- the returned values of @p@. The note about behavior of the combinator in--- the case when @p@ fails consuming input (see 'A.many') applies to 'some'--- as well.------ > word = some letter---- $optional------ @optional p@ tries to apply the parser @p@. It will parse @p@ or nothing.--- It only fails if @p@ fails after consuming input. On success result of--- @p@ is returned inside of 'Just', on failure 'Nothing' is returned.+-- In addition to the "Text.Megaparsec" module, which exports and re-exports+-- most 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.+--+-- It is common to start working with the library by defining a type synonym+-- like this:+--+-- > type Parser = Parsec Void Text+-- >                      ^    ^+-- >                      |    |+-- > Custom error component    Type of input+--+-- Then you can write type signatures like @Parser Int@—for a parser that+-- returns an 'Int' for example.+--+-- 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+-- 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 BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++module Text.Megaparsec+  ( -- * Re-exports+    module Text.Megaparsec.Pos+  , module Text.Megaparsec.Error+  , module Text.Megaparsec.Stream+  , module Control.Applicative.Combinators+    -- * Data types+  , State (..)+  , Parsec+  , ParsecT+    -- * Running parser+  , parse+  , parseMaybe+  , parseTest+  , parseTest'+  , runParser+  , runParser'+  , runParserT+  , runParserT'+    -- * Primitive combinators+  , MonadParsec (..)+    -- * Derivatives of primitive combinators+  , (<?>)+  , unexpected+  , match+  , region+  , takeRest+  , atEnd+    -- * Parser state combinators+  , getInput+  , setInput+  , getPosition+  , getNextTokenPosition+  , setPosition+  , pushPosition+  , popPosition+  , getTokensProcessed+  , setTokensProcessed+  , getTabWidth+  , setTabWidth+  , setParserState+    -- * Debugging+  , dbg )+where++import Control.Applicative.Combinators+import Control.DeepSeq+import Control.Monad+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.Identity+import Control.Monad.Reader.Class+import Control.Monad.State.Class hiding (state)+import Control.Monad.Trans+import Control.Monad.Trans.Identity+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Semigroup hiding (option)+import Data.Set (Set)+import Data.Typeable (Typeable)+import Debug.Trace+import GHC.Generics+import Text.Megaparsec.Error+import Text.Megaparsec.Pos+import Text.Megaparsec.Stream+import qualified Control.Applicative               as A+import qualified Control.Monad.Fail                as Fail+import qualified Control.Monad.RWS.Lazy            as L+import qualified Control.Monad.RWS.Strict          as S+import qualified Control.Monad.Trans.Reader        as L+import qualified Control.Monad.Trans.State.Lazy    as L+import qualified Control.Monad.Trans.State.Strict  as S+import qualified Control.Monad.Trans.Writer.Lazy   as L+import qualified Control.Monad.Trans.Writer.Strict as S+import qualified Data.List.NonEmpty                as NE+import qualified Data.Set                          as E++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++----------------------------------------------------------------------------+-- Data types++-- | 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+    --+    -- @since 5.2.0+  , stateTabWidth :: Pos+    -- ^ Tab width to use+  } deriving (Show, Eq, Data, Typeable, Generic)++instance NFData s => NFData (State s)++-- | All information available after parsing. This includes consumption of+-- input, success (with returned value) or failure (with parse error), and+-- parser state at the end of parsing.+--+-- See also: 'Consumption', 'Result'.++data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)++-- | This data structure represents an aspect of result of parser's work.+--+-- See also: 'Result', 'Reply'.++data Consumption+  = Consumed -- ^ Some part of input stream was consumed+  | Virgin   -- ^ No input was consumed++-- | This data structure represents an aspect of result of parser's work.+--+-- See also: 'Consumption', 'Reply'.++data Result t e a+  = OK a                   -- ^ Parser succeeded+  | Error (ParseError t e) -- ^ Parser failed++-- | 'Hints' represent collection of strings to be included into+-- 'ParserError' as “expected” message items when a parser fails without+-- consuming input right after successful parser that produced the hints.+--+-- For example, without hints you could get:+--+-- >>> parseTest (many (char 'r') <* eof) "ra"+-- 1:2:+-- unexpected 'a'+-- expecting end of input+--+-- We're getting better error messages with help of hints:+--+-- >>> parseTest (many (char 'r') <* eof) "ra"+-- 1:2:+-- unexpected 'a'+-- expecting 'r' or end of input++newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid)++-- | Convert 'ParseError' record into 'Hints'.++toHints :: ParseError t e -> Hints t+toHints (TrivialError _ _ ps) = Hints (if E.null ps then [] else [ps])+toHints (FancyError   _ _)    = mempty+{-# INLINE toHints #-}++-- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@.+--+-- Note that if resulting continuation gets 'ParseError' that has custom+-- data in it, hints are ignored.++withHints :: Ord (Token s)+  => Hints (Token s)   -- ^ Hints to use+  -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence+  -> ParseError (Token s) e -- ^ First argument of resulting continuation+  -> State s           -- ^ Second argument of resulting continuation+  -> m b+withHints (Hints ps') c e =+  case e of+    TrivialError pos us ps -> c (TrivialError pos us (E.unions (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 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 #-}++-- | 'Parsec' is a non-transformer variant of the more general 'ParsecT'+-- monad transformer.++type Parsec e s = ParsecT e s Identity++-- | @'ParsecT' e s m a@ is a parser with custom data component of error+-- @e@, stream type @s@, underlying monad @m@ and return type @a@.++newtype ParsecT e s m a = ParsecT+  { unParser+      :: forall b. State s+      -> (a -> State s   -> Hints (Token s) -> m b) -- consumed-OK+      -> (ParseError (Token s) e -> State s -> m b) -- consumed-error+      -> (a -> State s   -> Hints (Token s) -> m b) -- empty-OK+      -> (ParseError (Token s) e -> State s -> m b) -- empty-error+      -> m b }++instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where+  (<>) = A.liftA2 (<>)+  {-# INLINE (<>) #-}++instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where+  mempty = pure mempty+  {-# INLINE mempty #-}+  mappend = A.liftA2 mappend+  {-# INLINE mappend #-}++instance Functor (ParsecT e s m) where+  fmap = pMap++pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b+pMap f p = ParsecT $ \s cok cerr eok eerr ->+  unParser p s (cok . f) cerr (eok . f) eerr+{-# INLINE pMap #-}++instance Stream s => A.Applicative (ParsecT e s m) where+  pure     = pPure+  (<*>)    = pAp+  p1 *> p2 = p1 `pBind` const p2+  p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }++pAp :: Stream s+  => ParsecT e s m (a -> b)+  -> ParsecT e s m a+  -> ParsecT e s m b+pAp m k = ParsecT $ \s cok cerr eok eerr ->+  let mcok x s' hs = unParser k s' (cok . x) cerr+        (accHints hs (cok . x)) (withHints hs cerr)+      meok x s' hs = unParser k s' (cok . x) cerr+        (accHints hs (eok . x)) (withHints hs eerr)+  in unParser m s mcok cerr meok eerr+{-# INLINE pAp #-}++instance (Ord e, Stream s) => A.Alternative (ParsecT e s m) where+  empty  = mzero+  (<|>)  = mplus++instance Stream s => Monad (ParsecT e s m) where+  return = pure+  (>>=)  = pBind+  fail   = Fail.fail++pPure :: a -> ParsecT e s m a+pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty+{-# INLINE pPure #-}++pBind :: Stream s+  => ParsecT e s m a+  -> (a -> ParsecT e s m b)+  -> ParsecT e s m b+pBind m k = ParsecT $ \s cok cerr eok eerr ->+  let mcok x s' hs = unParser (k x) s' cok cerr+        (accHints hs cok) (withHints hs cerr)+      meok x s' hs = unParser (k x) s' cok cerr+        (accHints hs eok) (withHints hs eerr)+  in unParser m s mcok cerr meok eerr+{-# INLINE pBind #-}++instance 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 ->+  let d = E.singleton (ErrorFail msg)+  in eerr (FancyError pos d) s+{-# INLINE pFail #-}++mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a+mkPT k = ParsecT $ \s cok cerr eok eerr -> do+  (Reply s' consumption result) <- k s+  case consumption of+    Consumed ->+      case result of+        OK    x -> cok x s' mempty+        Error e -> cerr e s'+    Virgin ->+      case result of+        OK    x -> eok x s' mempty+        Error e -> eerr e s'++instance (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)++instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where+  get = lift get+  put = lift . put++instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where+  callCC f = mkPT $ \s ->+    callCC $ \c ->+      runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s+    where pack s a = Reply s Virgin (OK a)++instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where+  throwError = lift . throwError+  p `catchError` h = mkPT $ \s ->+    runParsecT p s `catchError` \e ->+      runParsecT (h e) s++instance (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+{-# INLINE pZero #-}++pPlus :: (Ord e, Stream s)+  => ParsecT e s m a+  -> ParsecT e s m a+  -> ParsecT e s m a+pPlus m n = ParsecT $ \s cok cerr eok eerr ->+  let meerr err ms =+        let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')+            neok x s' hs  = eok x s' (toHints err <> hs)+            neerr err' s' = eerr (err' <> err) (longestMatch ms s')+        in unParser n s cok ncerr neok neerr+  in unParser m s cok cerr eok meerr+{-# INLINE pPlus #-}++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+    LT -> s2+    EQ -> s2+    GT -> s1+{-# INLINE longestMatch #-}++instance MonadTrans (ParsecT e s) where+  lift amb = ParsecT $ \s _ _ eok _ ->+    amb >>= \a -> eok a s mempty++----------------------------------------------------------------------------+-- Running a parser++-- | @'parse' p file input@ runs parser @p@ over 'Identity' (see 'runParserT'+-- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a+-- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn+-- 'ParseError' into the string representation of the error message. See+-- "Text.Megaparsec.Error" if you need to do more advanced error analysis.+--+-- > main = case (parse numbers "" "11,2,43") of+-- >          Left err -> putStr (parseErrorPretty err)+-- >          Right xs -> print (sum xs)+-- >+-- > numbers = integer `sepBy` char ','++parse+  :: Parsec e s a -- ^ Parser to run+  -> String       -- ^ Name of source file+  -> s            -- ^ Input for parser+  -> Either (ParseError (Token s) e) a+parse = runParser++-- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the+-- result inside 'Just' on success and 'Nothing' on failure. This function+-- also parses 'eof', so if the parser doesn't consume all of its input, it+-- will fail.+--+-- The function is supposed to be useful for lightweight parsing, where+-- error messages (and thus file name) are not important and entire input+-- should be parsed. For example, it can be used when parsing of a single+-- number according to a specification of its format is desired.++parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a+parseMaybe p s =+  case parse (p <* eof) "" s of+    Left  _ -> Nothing+    Right x -> Just x++-- | The expression @'parseTest' p input@ applies the parser @p@ against+-- input @input@ and prints the result to stdout. Useful for testing.++parseTest :: ( ShowErrorComponent e+             , Ord (Token s)+             , ShowToken (Token s)+             , Show a )+  => Parsec e s a -- ^ Parser to run+  -> s            -- ^ Input for parser+  -> IO ()+parseTest p input =+  case parse p "" input of+    Left  e -> putStr (parseErrorPretty e)+    Right x -> print x++-- | 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)+    Right x -> print x++-- | @'runParser' p file input@ runs parser @p@ on the input stream of+-- tokens @input@, obtained from source @file@. The @file@ is only used in+-- error messages and may be the empty string. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- > parseFromFile p file = runParser p file <$> readFile file++runParser+  :: Parsec e s a -- ^ Parser to run+  -> String     -- ^ Name of source file+  -> s          -- ^ Input for parser+  -> Either (ParseError (Token s) e) a+runParser p name s = snd $ runParser' p (initialState name s)++-- | The function is similar to 'runParser' with the difference that it+-- accepts and returns parser state. This allows to specify arbitrary+-- textual position at the beginning of parsing, for example. This is the+-- most general way to run a parser over the 'Identity' monad.+--+-- @since 4.2.0++runParser'+  :: Parsec e s a -- ^ Parser to run+  -> State s    -- ^ Initial state+  -> (State s, Either (ParseError (Token s) e) a)+runParser' p = runIdentity . runParserT' p++-- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens+-- @input@, obtained from source @file@. The @file@ is only used in error+-- messages and may be the empty string. Returns a computation in the+-- underlying monad @m@ that returns either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right').++runParserT :: Monad m+  => ParsecT e s m a -- ^ Parser to run+  -> String        -- ^ Name of source file+  -> s             -- ^ Input for parser+  -> m (Either (ParseError (Token s) e) a)+runParserT p name s = snd `liftM` runParserT' p (initialState name s)++-- | This function is similar to 'runParserT', but like 'runParser'' it+-- accepts and returns parser state. This is thus the most general way to+-- run a parser.+--+-- @since 4.2.0++runParserT' :: Monad m+  => ParsecT e s m a -- ^ Parser to run+  -> State s       -- ^ Initial state+  -> m (State s, Either (ParseError (Token s) e) a)+runParserT' p s = do+  (Reply s' _ result) <- runParsecT p s+  case result of+    OK    x -> return (s', Right x)+    Error e -> return (s', Left  e)++-- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser'+-- are built upon this.++runParsecT :: Monad m+  => ParsecT e s m a -- ^ Parser to run+  -> State s       -- ^ Initial state+  -> m (Reply e s a)+runParsecT p s = unParser p s cok cerr eok eerr+  where cok a s' _  = return $ Reply s' Consumed (OK a)+        cerr err s' = return $ Reply s' Consumed (Error err)+        eok a s' _  = return $ Reply s' Virgin   (OK a)+        eerr err s' = return $ Reply s' Virgin   (Error err)++-- | Given name of source file and input construct initial state for parser.++initialState :: String -> s -> State s+initialState name s = State+  { stateInput           = s+  , statePos             = initialPos name :| []+  , stateTokensProcessed = 0+  , stateTabWidth        = defaultTabWidth }++----------------------------------------------------------------------------+-- Primitive combinators++-- | 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, A.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'.+  --+  -- @since 6.0.0++  fancyFailure+    :: Set (ErrorFancy e) -- ^ Fancy error components+    -> 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+  -- backtracks the parser state when @p@ fails (either consuming input or+  -- not).+  --+  -- This combinator is used whenever arbitrary look ahead is needed. Since+  -- it pretends that it hasn't consumed any input when @p@ fails, the+  -- ('A.<|>') combinator will try its second alternative even if the first+  -- parser failed while consuming input.+  --+  -- For example, here is a parser that is supposed to parse the word “let”+  -- or the word “lexical”:+  --+  -- >>> parseTest (string "let" <|> string "lexical") "lexical"+  -- 1:1:+  -- unexpected "lex"+  -- expecting "let"+  --+  -- What happens here? The first parser consumes “le” and fails (because it+  -- doesn't see a “t”). The second parser, however, isn't tried, since the+  -- first parser has already consumed some input! 'try' fixes this behavior+  -- and allows backtracking to work:+  --+  -- >>> parseTest (try (string "let") <|> string "lexical") "lexical"+  -- "lexical"+  --+  -- 'try' also improves error messages in case of overlapping alternatives,+  -- because Megaparsec's hint system can be used:+  --+  -- >>> parseTest (try (string "let") <|> string "lexical") "le"+  -- 1:1:+  -- unexpected "le"+  -- expecting "let" or "lexical"+  --+  -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks+  -- automatically (see 'tokens'), so it does not need 'try'. However, the+  -- examples above demonstrate the idea behind 'try' so well that it was+  -- decided to keep them. You still need to use 'try' when your+  -- alternatives are complex, composite parsers.++  try :: m a -> m a++  -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not)+  -- the whole parser behaves like @p@ succeeded without consuming anything+  -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no+  -- effect, i.e. it will fail consuming input if @p@ fails consuming input.+  -- Combine with 'try' if this is undesirable.++  lookAhead :: m a -> m a++  -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This+  -- parser /never consumes/ any input and /never modifies/ parser state. It+  -- can be used to implement the “longest match” rule.++  notFollowedBy :: m a -> m ()++  -- | @'withRecovery' r p@ allows continue parsing even if parser @p@+  -- fails. In this case @r@ is called with the actual 'ParseError' as its+  -- argument. Typical usage is to return a value signifying failure to+  -- parse this particular object and to consume some part of the input up+  -- to the point where the next object starts.+  --+  -- Note that if @r@ fails, original error message is reported as if+  -- without 'withRecovery'. In no way recovering parser @r@ can influence+  -- error messages.+  --+  -- @since 4.4.0++  withRecovery+    :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure+    -> m a             -- ^ Original parser+    -> m a             -- ^ Parser that can recover from failures++  -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should+  -- it happen, without actually ending parsing, but instead getting the+  -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right'+  -- as usual. Note that this primitive just allows you to observe parse+  -- errors as they happen, it does not backtrack or change how the @p@+  -- parser works in any way.+  --+  -- @since 5.1.0++  observing+    :: m a             -- ^ The parser to run+    -> m (Either (ParseError (Token s) e) a)++  -- | This parser only succeeds at the end of the input.++  eof :: m ()++  -- | The parser @'token' test mrep@ accepts a token @t@ with result @x@+  -- when the function @test t@ returns @'Right' x@. @mrep@ may provide+  -- representation of the token to report in error messages when input+  -- stream in empty.+  --+  -- This is the most primitive combinator for accepting tokens. For+  -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:+  --+  -- > satisfy f = token testChar Nothing+  -- >   where+  -- >     testChar x =+  -- >       if f x+  -- >         then Right x+  -- >         else Left (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++  -- | 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.+  --+  -- This can be used for example to write 'Text.Megaparsec.Char.string':+  --+  -- > string = tokens (==)+  --+  -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking+  -- primitive, which means that if it fails, it never consumes any input.+  -- This is done to make its consumption model match how error messages for+  -- this primitive are reported (which becomes an important thing as user+  -- gets more control with primitives like 'withRecovery'):+  --+  -- >>> parseTest (string "abc") "abd"+  -- 1:1:+  -- unexpected "abd"+  -- expecting "abc"+  --+  -- This means, in particular, that it's no longer necessary to use 'try'+  -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and+  -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect+  -- performance in any way.++  tokens+    :: (Tokens s -> Tokens s -> Bool)+       -- ^ Predicate to check equality of tokens+    -> Tokens s+       -- ^ List of tokens to parse+    -> 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:+  --+  -- > 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.+  --+  -- @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++  -- | 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.+  --+  -- @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++  -- | 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+  -- 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+  --+  -- 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++  -- | Return the full parser state as a 'State' record.++  getParserState :: m (State s)++  -- | @'updateParserState' f@ applies the function @f@ to the parser state.++  updateParserState :: (State s -> State s) -> m ()++instance (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+  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 #-}++pFancyFailure+  :: Set (ErrorFancy e)+  -> ParsecT e s m a+pFancyFailure xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->+  eerr (FancyError pos xs) s+{-# INLINE pFancyFailure #-}++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 $+        case err of+          (TrivialError pos us _) ->+            TrivialError pos us (maybe E.empty E.singleton el)+          _ -> err+  in unParser p s cok' cerr eok' eerr'+{-# INLINE pLabel #-}++pTry :: ParsecT e s m a -> ParsecT e s m a+pTry p = ParsecT $ \s cok _ eok eerr ->+  let eerr' err _ = eerr err s+  in unParser p s cok eerr' eok eerr'+{-# INLINE pTry #-}++pLookAhead :: ParsecT e s m a -> ParsecT e s m a+pLookAhead p = ParsecT $ \s _ cerr eok eerr ->+  let eok' a _ _ = eok a s mempty+  in unParser p s eok' cerr eok' eerr+{-# INLINE pLookAhead #-}++pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()+pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr ->+  let what = maybe EndOfInput (Tokens . nes . fst) (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'+{-# INLINE pNotFollowedBy #-}++pWithRecovery+  :: (ParseError (Token s) e -> ParsecT e s m a)+  -> ParsecT e s m a+  -> ParsecT e s m a+pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->+  let mcerr err ms =+        let rcok x s' _ = cok x s' mempty+            rcerr   _ _ = cerr err ms+            reok x s' _ = eok x s' (toHints err)+            reerr   _ _ = cerr err ms+        in unParser (r err) ms rcok rcerr reok reerr+      meerr err ms =+        let rcok x s' _ = cok x s' (toHints err)+            rcerr   _ _ = eerr err ms+            reok x s' _ = eok x s' (toHints err)+            reerr   _ _ = eerr err ms+        in unParser (r err) ms rcok rcerr reok reerr+  in unParser p s cok mcerr eok meerr+{-# INLINE pWithRecovery #-}++pObserving+  :: ParsecT e s m a+  -> ParsecT e s m (Either (ParseError (Token s) e) a)+pObserving p = ParsecT $ \s cok _ eok _ ->+  let cerr' err s' = cok (Left err) s' mempty+      eerr' err s' = eok (Left err) s' (toHints err)+  in unParser p s (cok . Right) cerr' (eok . Right) eerr'+{-# INLINE pObserving #-}++pEof :: forall e s m. Stream s => ParsecT e s m ()+pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr ->+  case 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)+{-# 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 ->+  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) ->+      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+{-# 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 _ _ eerr ->+  let pxy = Proxy :: Proxy s+      unexpect pos' u =+        let us = pure u+            ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts+        in TrivialError pos' us ps+      len = chunkLength pxy tts+  in case takeN_ len input of+    Nothing ->+      eerr (unexpect (pos:|z) EndOfInput) s+    Just (tts', input') ->+      if f tts tts'+        then let !npos = advanceN pxy w pos tts'+             in cok tts' (State input' (npos:|z) (tp + len) w) 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)+{-# 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 _ ->+  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+{-# 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 ->+  let pxy = Proxy :: Proxy s+      (ts, input') = takeWhile_ f input+      len = chunkLength pxy ts+      el = Label <$> (ml >>= NE.nonEmpty)+      hs =+        case el of+          Nothing -> mempty+          Just l -> (Hints . 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+{-# 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+      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+{-# INLINE pTakeP #-}++pGetParserState :: ParsecT e s m (State s)+pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty+{-# INLINE pGetParserState #-}++pUpdateParserState :: (State s -> State s) -> ParsecT e s m ()+pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty+{-# INLINE pUpdateParserState #-}++nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}++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 ->+    (,s) . fst <$> lookAhead (m s)+  notFollowedBy (L.StateT m) = L.StateT $ \s ->+    notFollowedBy (fst <$> m s) >> return ((),s)+  withRecovery r (L.StateT m) = L.StateT $ \s ->+    withRecovery (\e -> L.runStateT (r e) s) (m s)+  observing     (L.StateT m) = L.StateT $ \s ->+    fixs s <$> observing (m s)+  eof                        = lift eof+  token test mt              = lift (token test mt)+  tokens e ts                = lift (tokens e ts)+  takeWhileP l f             = lift (takeWhileP l f)+  takeWhile1P l f            = lift (takeWhile1P l f)+  takeP l n                  = lift (takeP l n)+  getParserState             = lift getParserState+  updateParserState f        = lift (updateParserState f)++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 ->+    (,s) . fst <$> lookAhead (m s)+  notFollowedBy (S.StateT m) = S.StateT $ \s ->+    notFollowedBy (fst <$> m s) >> return ((),s)+  withRecovery r (S.StateT m) = S.StateT $ \s ->+    withRecovery (\e -> S.runStateT (r e) s) (m s)+  observing     (S.StateT m) = S.StateT $ \s ->+    fixs s <$> observing (m s)+  eof                        = lift eof+  token test mt              = lift (token test mt)+  tokens e ts                = lift (tokens e ts)+  takeWhileP l f             = lift (takeWhileP l f)+  takeWhile1P l f            = lift (takeWhile1P l f)+  takeP l n                  = lift (takeP l n)+  getParserState             = lift getParserState+  updateParserState f        = lift (updateParserState f)++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+  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)++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)++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)++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+    notFollowedBy (void $ m r s)+    return ((),s,mempty)+  withRecovery   n (L.RWST m) = L.RWST $ \r s ->+    withRecovery (\e -> L.runRWST (n e) r s) (m r s)+  observing        (L.RWST m) = L.RWST $ \r s ->+    fixs' s <$> observing (m r s)+  eof                         = lift eof+  token test mt               = lift (token test mt)+  tokens e ts                 = lift (tokens e ts)+  takeWhileP l f              = lift (takeWhileP l f)+  takeWhile1P l f             = lift (takeWhile1P l f)+  takeP l n                   = lift (takeP l n)+  getParserState              = lift getParserState+  updateParserState f         = lift (updateParserState f)++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+    notFollowedBy (void $ m r s)+    return ((),s,mempty)+  withRecovery   n (S.RWST m) = S.RWST $ \r s ->+    withRecovery (\e -> S.runRWST (n e) r s) (m r s)+  observing        (S.RWST m) = S.RWST $ \r s ->+    fixs' s <$> observing (m r s)+  eof                         = lift eof+  token test mt               = lift (token test mt)+  tokens e ts                 = lift (tokens e ts)+  takeWhileP l f              = lift (takeWhileP l f)+  takeWhile1P l f             = lift (takeWhile1P l f)+  takeP l n                   = lift (takeP l n)+  getParserState              = lift getParserState+  updateParserState f         = lift (updateParserState f)++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+  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++fixs :: s -> Either a (b, s) -> (Either a b, s)+fixs s (Left a)       = (Left a, s)+fixs _ (Right (b, s)) = (Right b, s)+{-# INLINE fixs #-}++fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w)+fixs' s (Left a)        = (Left a, s, mempty)+fixs' _ (Right (b,s,w)) = (Right b, s, w)+{-# INLINE fixs' #-}++----------------------------------------------------------------------------+-- Derivatives of primitive combinators++-- | A synonym for 'label' in the form of an operator.++infix 0 <?>++(<?>) :: MonadParsec e s m => m a -> String -> m a+(<?>) = flip label+{-# INLINE (<?>) #-}++-- | 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+{-# INLINE unexpected #-}++-- | 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).+--+-- @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 f m = do+  r <- observing m+  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+    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)+--+-- @since 6.0.0++takeRest :: MonadParsec e s m => m (Tokens s)+takeRest = takeWhileP Nothing (const True)+{-# INLINE takeRest #-}++-- | Return 'True' when end of input has been reached.+--+-- @since 6.0.0++atEnd :: MonadParsec e s m => m Bool+atEnd = option False (True <$ eof)+{-# INLINE atEnd #-}++----------------------------------------------------------------------------+-- Parser state combinators++-- | Return the current input.++getInput :: MonadParsec e s m => m s+getInput = stateInput <$> getParserState++-- | @'setInput' input@ continues parsing with @input@. The 'getInput' and+-- 'setInput' functions can for example be used to deal with include files.++setInput :: MonadParsec e s m => s -> m ()+setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w)++-- | Return the current source position.+--+-- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'.++getPosition :: MonadParsec e s m => m SourcePos+getPosition = NE.head . statePos <$> getParserState++-- | Get the position where the next token in the stream begins. If the+-- stream is empty, return 'Nothing'.+--+-- @since 5.3.0++getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos)+getNextTokenPosition = do+  State {..} <- getParserState+  let f = 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: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'.++setPosition :: MonadParsec e s m => SourcePos -> m ()+setPosition pos = updateParserState $ \(State s (_:|z) tp w) ->+  State s (pos:|z) tp w++-- | Push a position into stack of positions and continue parsing working+-- with this position. Useful for working with include files and the like.+--+-- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.+--+-- @since 5.0.0++pushPosition :: MonadParsec e s m => SourcePos -> m ()+pushPosition pos = updateParserState $ \(State s z tp w) ->+  State s (NE.cons pos z) tp w++-- | Pop a position from the stack of positions unless it only contains one+-- element (in that case the stack of positions remains the same). This is+-- how to return to previous source file after 'pushPosition'.+--+-- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.+--+-- @since 5.0.0++popPosition :: MonadParsec e s m => m ()+popPosition = updateParserState $ \(State s z tp w) ->+  case snd (NE.uncons z) of+    Nothing -> State s z  tp w+    Just z' -> State s z' tp w++-- | Get the number of tokens processed so far.+--+-- @since 6.0.0++getTokensProcessed :: MonadParsec e s m => m Int+getTokensProcessed = stateTokensProcessed <$> getParserState++-- | Set the number of tokens processed so far.+--+-- @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@.++setParserState :: MonadParsec e s m => State s -> m ()+setParserState st = updateParserState (const st)++----------------------------------------------------------------------------+-- Debugging++-- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated+-- it also prints information useful for debugging. The @label@ is only used+-- to refer to this parser in the debugging output. This combinator uses the+-- 'trace' function from "Debug.Trace" under the hood.+--+-- Typical usage is to wrap every sub-parser in misbehaving parser with+-- 'dbg' assigning meaningful labels. Then give it a shot and go through the+-- print-out. As of current version, this combinator prints all available+-- information except for /hints/, which are probably only interesting to+-- the maintainer of Megaparsec itself and may be quite verbose to output in+-- general. Let me know if you would like to be able to see hints in the+-- debugging output.+--+-- The output itself is pretty self-explanatory, although the following+-- abbreviations should be clarified (they are derived from the low-level+-- source code):+--+--     * @COK@—“consumed OK”. The parser consumed input and succeeded.+--     * @CERR@—“consumed error”. The parser consumed input and failed.+--     * @EOK@—“empty OK”. The parser succeeded without consuming input.+--     * @EERR@—“empty error”. The parser failed without consuming input.+--+-- Finally, it's not possible to lift this function into some monad+-- transformers without introducing surprising behavior (e.g. unexpected+-- state backtracking) or adding otherwise redundant constraints (e.g.+-- 'Show' instance for state), so this helper is only available for+-- 'ParsecT' monad, not 'MonadParsec' in general.+--+-- @since 5.1.0++dbg :: forall e s m a.+  ( Stream s+  , ShowToken (Token s)+  , ShowErrorComponent e+  , Show a )+  => String            -- ^ Debugging label+  -> ParsecT e s m a   -- ^ Parser to debug+  -> ParsecT e s m a   -- ^ Parser that prints debugging messages+dbg lbl p = ParsecT $ \s cok cerr eok eerr ->+  let l = dbgLog lbl :: DbgItem s e a -> String+      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 single piece of info to be rendered with 'dbgLog'.++data DbgItem s e a+  = DbgIn   [Token s]+  | DbgCOK  [Token s] a+  | DbgCERR [Token s] (ParseError (Token s) e)+  | DbgEOK  [Token s] a+  | DbgEERR [Token s] (ParseError (Token s) e)++-- | Render a single piece of debugging info.++dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s))+  => String            -- ^ Debugging label+  -> DbgItem s e a     -- ^ Information to render+  -> String            -- ^ Rendered result+dbgLog lbl item = prefix msg+  where+    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines+    msg = case item of+      DbgIn   ts   ->+        "IN: " ++ showStream ts+      DbgCOK  ts a ->+        "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a+      DbgCERR ts e ->+        "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e+      DbgEOK  ts a ->+        "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a+      DbgEERR ts e ->+        "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e++-- | Pretty-print a list of tokens.++showStream :: ShowToken t => [t] -> String+showStream ts =+  case NE.nonEmpty ts of+    Nothing -> "<EMPTY>"+    Just ne ->+      let (h, r) = splitAt 40 (showTokens ne)+      in if null r then h else h ++ " <…>"++-- | Calculate number of consumed tokens given 'State' of parser before and+-- after parsing.++streamDelta+  :: State s           -- ^ State of parser before consumption+  -> State s           -- ^ State of parser after consumption+  -> Int               -- ^ Number of consumed tokens+streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed 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 chunk -> chunkToTokens (Proxy :: Proxy s) chunk
+ Text/Megaparsec/Byte.hs view
@@ -0,0 +1,235 @@+-- |+-- Module      :  Text.Megaparsec.Byte+-- Copyright   :  © 2015–2017 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Commonly used binary parsers.+--+-- @since 6.0.0++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++module Text.Megaparsec.Byte+  ( -- * Simple parsers+    newline+  , crlf+  , eol+  , tab+  , space+  , space1+    -- * 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+    -- * Sequence of bytes+  , C.string+  , C.string' )+where++import Control.Applicative+import Data.Char+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++----------------------------------------------------------------------------+-- Simple parsers++-- | Parse a newline byte.++newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+newline = C.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])+{-# INLINE crlf #-}++-- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the+-- sequence of characters parsed.++eol :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s)+eol = (tokenToChunk (Proxy :: Proxy s) <$> newline)+  <|> crlf+  <?> "end of line"+{-# INLINE eol #-}++-- | Parse a tab character.++tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+tab = C.char 9+{-# INLINE tab #-}++-- | Skip /zero/ or more white space characters.+--+-- See also: 'skipMany' and 'spaceChar'.++space :: (MonadParsec e s m, Token s ~ Word8) => m ()+space = void $ takeWhileP (Just "white space") isSpace'+{-# INLINE space #-}++-- | Skip /one/ or more white space characters.+--+-- See also: 'skipSome' and 'spaceChar'.++space1 :: (MonadParsec e s m, Token s ~ Word8) => m ()+space1 = void $ takeWhile1P (Just "white space") isSpace'+{-# INLINE space1 #-}++----------------------------------------------------------------------------+-- 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"+{-# 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"+{-# 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"+{-# 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"+{-# 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"+{-# 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"+{-# 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"+{-# 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"+  where+    isDigit' x = x >= 48 && x <= 57+{-# INLINE digitChar #-}++-- | 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"+  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"+{-# 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"+{-# INLINE asciiChar #-}++----------------------------------------------------------------------------+-- More general parsers++-- | The same as 'char' but case-insensitive. This parser returns the+-- actually parsed character preserving its case.+--+-- >>> parseTest (char' 101) "E"+-- 69 -- 'E'+-- >>> parseTest (char' 101) "G"+-- 1:1:+-- unexpected 'G'+-- expecting 'E' or 'e'++char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s)+char' c = choice+  [ 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+{-# INLINE char' #-}++----------------------------------------------------------------------------+-- Helpers++-- | 'Word8'-specialized version of 'isSpace'.++isSpace' :: Word8 -> Bool+isSpace' x+  | x >= 9 && x <= 13 = True+  | x == 32           = True+  | x == 160          = True+  | otherwise         = False+{-# INLINE isSpace' #-}++-- | Convert a byte to char.++toChar :: Word8 -> Char+toChar = chr . fromIntegral+{-# INLINE toChar #-}++-- | Convert a char to byte.++fromChar :: Char -> Maybe Word8+fromChar x = let p = ord x in+  if p > 0xff+    then Nothing+    else Just (fromIntegral p)+{-# INLINE fromChar #-}
+ Text/Megaparsec/Byte/Lexer.hs view
@@ -0,0 +1,243 @@+-- |+-- Module      :  Text.Megaparsec.Byte.Lexer+-- Copyright   :  © 2015–2017 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Stripped-down version of "Text.Megaparsec.Char.Lexer" for streams of+-- bytes.+--+-- This module is intended to be imported qualified:+--+-- > import qualified Text.Megaparsec.Byte.Lexer as L++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++module Text.Megaparsec.Byte.Lexer+  ( -- * White space+    C.space+  , C.lexeme+  , C.symbol+  , C.symbol'+  , skipLineComment+  , skipBlockComment+  , skipBlockCommentNested+    -- * Numbers+  , decimal+  , octal+  , hexadecimal+  , scientific+  , float+  , signed )+where++import Control.Applicative+import Data.Functor (void)+import Data.List (foldl')+import Data.Proxy+import Data.Scientific (Scientific)+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++----------------------------------------------------------------------------+-- White space++-- | Given comment prefix this function returns a parser that skips line+-- comments. Note that it stops just before the newline character but+-- doesn't consume the newline. Newline is either supposed to be consumed by+-- 'space' parser or picked up manually.++skipLineComment :: (MonadParsec e s m, Token s ~ Word8)+  => Tokens s          -- ^ Line comment prefix+  -> m ()+skipLineComment prefix =+  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)+  where+    p = string start+    n = 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 start end = p >> void (manyTill e n)+  where+    e = skipBlockCommentNested start end <|> void anyChar+    p = string start+    n = string end+{-# INLINEABLE skipBlockCommentNested #-}++----------------------------------------------------------------------------+-- Numbers++-- | Parse an integer in decimal representation according to the format of+-- integer literals described in the Haskell report.+--+-- If you need to parse signed integers, see 'signed' combinator.++decimal+  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral 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_ = mkNum <$> takeWhile1P (Just "digit") isDigit+  where+    mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a w = a * 10 + fromIntegral (w - 48)++-- | Parse an integer in octal representation. Representation of octal+-- number is expected to be according to the Haskell report except for the+-- fact that this parser doesn't parse “0o” or “0O” prefix. It is a+-- responsibility of the programmer to parse correct prefix before parsing+-- the number itself.+--+-- 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"+  where+    mkNum        = 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+-- hexadecimal number is expected to be according to the Haskell report+-- except for the fact that this parser doesn't parse “0x” or “0X” prefix.+-- It is a responsibility of the programmer to parse correct prefix before+-- parsing the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal++hexadecimal+  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)+  => m a+hexadecimal = mkNum+  <$> takeWhile1P Nothing isHexDigit+  <?> "hexadecimal integer"+  where+    mkNum        = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a w+      | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48)+      | w >= 97            = a * 16 + fromIntegral (w - 87)+      | otherwise          = a * 16 + fromIntegral (w - 55)+    isHexDigit w =+      (w >= 48 && w <= 57)  ||+      (w >= 97 && w <= 102) ||+      (w >= 65 && w <= 70)+{-# INLINEABLE hexadecimal #-}++-- | Parse a floating point value as a 'Scientific' number. 'Scientific' is+-- great for parsing of arbitrary precision numbers coming from an untrusted+-- source. See documentation in "Data.Scientific" for more information.+--+-- The parser can be used to parse integers or floating point values. Use+-- functions like 'Data.Scientific.floatingOrInteger' from "Data.Scientific"+-- to test and extract integer or real values.+--+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.++scientific+  :: forall e s m. (MonadParsec e s m, Token s ~ Word8)+  => m Scientific+scientific = do+  let pxy = Proxy :: Proxy s+  c' <- decimal_+  SP c e' <- option (SP c' 0) $ 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)+    mkNum <$> takeWhile1P (Just "digit") isDigit+  e <- option e' $ do+    void (char' 101)+    (+ e') <$> signed (return ()) decimal_+  return (Sci.scientific c e)+{-# INLINEABLE scientific #-}++data SP = SP !Integer {-# UNPACK #-} !Int++-- | Parse a floating point number without sign. There are differences+-- between the syntax for floating point literals described in the Haskell+-- report and what this function accepts. In particular, it does not require+-- fractional part and accepts inputs like @\"3\"@ returning @3.0@.+--+-- This is a simple short-cut defined as:+--+-- > float = Sci.toRealFloat <$> scientific <?> "floating point number"+--+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.++float :: (MonadParsec e s m, Token s ~ Word8, RealFloat a) => m a+float = Sci.toRealFloat <$> scientific <?> "floating point number"+{-# INLINEABLE float #-}++-- | @'signed' space p@ parser parses an optional sign character (“+” or+-- “-”), then if there is a sign it consumes optional white space (using+-- @space@ parser), then it runs parser @p@ which should return a number.+-- Sign of the number is changed according to the previously parsed sign+-- character.+--+-- For example, to parse signed integer you can write:+--+-- > lexeme        = L.lexeme spaceConsumer+-- > integer       = lexeme L.decimal+-- > signedInteger = L.signed spaceConsumer integer++signed :: (MonadParsec e s m, Token s ~ Word8, Num a)+  => 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+  where+    sign = (id <$ char 43) <|> (negate <$ char 45)+{-# INLINEABLE signed #-}++----------------------------------------------------------------------------+-- Helpers++-- | A fast predicate to check if given 'Word8' is a digit in ASCII.++isDigit :: Word8 -> Bool+isDigit w = w - 48 < 10+{-# INLINE isDigit #-}
− Text/Megaparsec/ByteString.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with strict 'ByteString'.--module Text.Megaparsec.ByteString (Parser) where--import Data.ByteString-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for strict--- 'ByteString's.--type Parser = Parsec Dec ByteString
− Text/Megaparsec/ByteString/Lazy.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.ByteString.Lazy--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with lazy 'ByteString'.--module Text.Megaparsec.ByteString.Lazy (Parser) where--import Data.ByteString.Lazy-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change the type of input--- stream by importing different “type modules”. This one is for lazy--- 'ByteString's.--type Parser = Parsec Dec ByteString
Text/Megaparsec/Char.hs view
@@ -11,9 +11,11 @@ -- -- Commonly used character parsers. -{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}  module Text.Megaparsec.Char   ( -- * Simple parsers@@ -22,6 +24,7 @@   , eol   , tab   , space+  , space1     -- * Categories of characters   , controlChar   , spaceChar@@ -46,10 +49,9 @@   , char   , char'   , anyChar+  , notChar   , oneOf-  , oneOf'   , noneOf-  , noneOf'   , satisfy     -- * Sequence of characters   , string@@ -58,17 +60,17 @@  import Control.Applicative import Data.Char+import Data.Function (on)+import Data.Functor (void) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromJust)-import qualified Data.Set as E--import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Prim+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 (), any, elem, notElem)-import Prelude hiding (any, elem, notElem)+import Data.Foldable (Foldable (), elem, notElem)+import Prelude hiding (elem, notElem) #endif  ----------------------------------------------------------------------------@@ -76,29 +78,29 @@  -- | Parse a newline character. -newline :: (MonadParsec e s m, Token s ~ Char) => m Char+newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-}  -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. -crlf :: (MonadParsec e s m, Token s ~ Char) => m String-crlf = string "\r\n"+crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s)+crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-}  -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed.------ > eol = (pure <$> newline) <|> crlf <?> "end of line" -eol :: (MonadParsec e s m, Token s ~ Char) => m String-eol = (pure <$> newline) <|> crlf <?> "end of line"+eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s)+eol = (tokenToChunk (Proxy :: Proxy s) <$> newline)+  <|> crlf+  <?> "end of line" {-# INLINE eol #-}  -- | Parse a tab character. -tab :: (MonadParsec e s m, Token s ~ Char) => m Char+tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-} @@ -107,23 +109,33 @@ -- See also: 'skipMany' and 'spaceChar'.  space :: (MonadParsec e s m, Token s ~ Char) => m ()-space = skipMany spaceChar+space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | 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 #-}+ ---------------------------------------------------------------------------- -- Categories of characters  -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode). -controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char+controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl <?> "control character" {-# INLINE controlChar #-}  -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. -spaceChar :: (MonadParsec e s m, Token s ~ Char) => m Char+spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace <?> "white space" {-# INLINE spaceChar #-} @@ -131,20 +143,20 @@ -- case is used by a small number of letter ligatures like the -- single-character form of Lj. -upperChar :: (MonadParsec e s m, Token s ~ Char) => m Char+upperChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) upperChar = satisfy isUpper <?> "uppercase letter" {-# INLINE upperChar #-}  -- | Parse a lower-case alphabetic Unicode character. -lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char+lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower <?> "lowercase letter" {-# INLINE lowerChar #-}  -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter. -letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char+letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter <?> "letter" {-# INLINE letterChar #-} @@ -154,142 +166,143 @@ -- parser but not by 'digitChar'. Such digits may be part of identifiers but -- are not used by the printer and reader to represent numbers. -alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m Char+alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) alphaNumChar = satisfy isAlphaNum <?> "alphanumeric character" {-# INLINE alphaNumChar #-}  -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space. -printChar :: (MonadParsec e s m, Token s ~ Char) => m Char+printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint <?> "printable character" {-# INLINE printChar #-}  -- | Parse an ASCII digit, i.e between “0” and “9”. -digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char+digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit <?> "digit" {-# INLINE digitChar #-}  -- | Parse an octal digit, i.e. between “0” and “7”. -octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char+octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) octDigitChar = satisfy isOctDigit <?> "octal digit" {-# INLINE octDigitChar #-}  -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. -hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char+hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit <?> "hexadecimal digit" {-# INLINE hexDigitChar #-}  -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters. -markChar :: (MonadParsec e s m, Token s ~ Char) => m Char+markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark <?> "mark character" {-# INLINE markChar #-}  -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc. -numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char+numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber <?> "numeric character" {-# INLINE numberChar #-}  -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes. -punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m Char+punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) punctuationChar = satisfy isPunctuation <?> "punctuation" {-# INLINE punctuationChar #-}  -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols. -symbolChar :: (MonadParsec e s m, Token s ~ Char) => m Char+symbolChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) symbolChar = satisfy isSymbol <?> "symbol" {-# INLINE symbolChar #-}  -- | Parse a Unicode space and separator characters. -separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char+separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator <?> "separator" {-# INLINE separatorChar #-}  -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. -asciiChar :: (MonadParsec e s m, Token s ~ Char) => m Char+asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii <?> "ASCII character" {-# INLINE asciiChar #-}  -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. -latin1Char :: (MonadParsec e s m, Token s ~ Char) => m Char+latin1Char :: (MonadParsec e s m, Token s ~ Char) => m (Token s) latin1Char = satisfy isLatin1 <?> "Latin-1 character" {-# INLINE latin1Char #-} --- | @charCategory cat@ parses character in Unicode General Category @cat@,--- see 'Data.Char.GeneralCategory'.+-- | @'charCategory' cat@ parses character in Unicode General Category+-- @cat@, see 'Data.Char.GeneralCategory'. -charCategory :: (MonadParsec e s m, Token s ~ Char) => GeneralCategory -> m Char+charCategory :: (MonadParsec e s m, Token s ~ Char)+  => GeneralCategory+  -> m (Token s) charCategory cat = satisfy ((== cat) . generalCategory) <?> categoryName cat {-# INLINE charCategory #-}  -- | Return the human-readable name of Unicode General Category.  categoryName :: GeneralCategory -> String-categoryName cat =-  fromJust $ lookup cat-  [ (UppercaseLetter     , "uppercase letter")-  , (LowercaseLetter     , "lowercase letter")-  , (TitlecaseLetter     , "titlecase letter")-  , (ModifierLetter      , "modifier letter")-  , (OtherLetter         , "other letter")-  , (NonSpacingMark      , "non-spacing mark")-  , (SpacingCombiningMark, "spacing combining mark")-  , (EnclosingMark       , "enclosing mark")-  , (DecimalNumber       , "decimal number character")-  , (LetterNumber        , "letter number character")-  , (OtherNumber         , "other number character")-  , (ConnectorPunctuation, "connector punctuation")-  , (DashPunctuation     , "dash punctuation")-  , (OpenPunctuation     , "open punctuation")-  , (ClosePunctuation    , "close punctuation")-  , (InitialQuote        , "initial quote")-  , (FinalQuote          , "final quote")-  , (OtherPunctuation    , "other punctuation")-  , (MathSymbol          , "math symbol")-  , (CurrencySymbol      , "currency symbol")-  , (ModifierSymbol      , "modifier symbol")-  , (OtherSymbol         , "other symbol")-  , (Space               , "white space")-  , (LineSeparator       , "line separator")-  , (ParagraphSeparator  , "paragraph separator")-  , (Control             , "control character")-  , (Format              , "format character")-  , (Surrogate           , "surrogate character")-  , (PrivateUse          , "private-use Unicode character")-  , (NotAssigned         , "non-assigned Unicode character") ]+categoryName = \case+  UppercaseLetter      -> "uppercase letter"+  LowercaseLetter      -> "lowercase letter"+  TitlecaseLetter      -> "titlecase letter"+  ModifierLetter       -> "modifier letter"+  OtherLetter          -> "other letter"+  NonSpacingMark       -> "non-spacing mark"+  SpacingCombiningMark -> "spacing combining mark"+  EnclosingMark        -> "enclosing mark"+  DecimalNumber        -> "decimal number character"+  LetterNumber         -> "letter number character"+  OtherNumber          -> "other number character"+  ConnectorPunctuation -> "connector punctuation"+  DashPunctuation      -> "dash punctuation"+  OpenPunctuation      -> "open punctuation"+  ClosePunctuation     -> "close punctuation"+  InitialQuote         -> "initial quote"+  FinalQuote           -> "final quote"+  OtherPunctuation     -> "other punctuation"+  MathSymbol           -> "math symbol"+  CurrencySymbol       -> "currency symbol"+  ModifierSymbol       -> "modifier symbol"+  OtherSymbol          -> "other symbol"+  Space                -> "white space"+  LineSeparator        -> "line separator"+  ParagraphSeparator   -> "paragraph separator"+  Control              -> "control character"+  Format               -> "format character"+  Surrogate            -> "surrogate character"+  PrivateUse           -> "private-use Unicode character"+  NotAssigned          -> "non-assigned Unicode character"  ---------------------------------------------------------------------------- -- More general parsers --- | @char c@ parses a single character @c@.+-- | @'char' c@ parses a single character @c@. -- -- > semicolon = char ';' -char :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char+char :: MonadParsec e s m => Token s -> m (Token s) char c = token testChar (Just c)   where-    f x = E.singleton (Tokens (x:|[]))+    f x = Tokens (x:|[])     testChar x =       if x == c         then Right x-        else Left (f x, f c, E.empty)+        else Left (pure (f x), E.singleton (f c)) {-# INLINE char #-}  -- | The same as 'char' but case-insensitive. This parser returns the@@ -302,8 +315,8 @@ -- unexpected 'G' -- expecting 'E' or 'e' -char' :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char-char' c = choice [char c, char $ swapCase c]+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@@ -313,11 +326,20 @@  -- | This parser succeeds for any character. Returns the parsed character. -anyChar :: (MonadParsec e s m, Token s ~ Char) => m Char+anyChar :: MonadParsec e s m => m (Token s) anyChar = satisfy (const True) <?> "character" {-# INLINE anyChar #-} --- | @oneOf cs@ succeeds if the current character is in the supplied+-- | 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@@ -326,61 +348,65 @@ -- 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, Token s ~ Char) => f Char -> m Char+oneOf :: (Foldable f, MonadParsec e s m)+  => f (Token s)+  -> m (Token s) oneOf cs = satisfy (`elem` cs) {-# INLINE oneOf #-} --- | The same as 'oneOf', but case-insensitive. Returns the parsed character--- preserving its case.------ > vowel = oneOf' "aeiou" <?> "vowel"--oneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-oneOf' cs = satisfy (`elemi` cs)-{-# INLINE oneOf' #-}---- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current character+-- | As the dual of 'oneOf', @'noneOf' cs@ succeeds if the current character -- /not/ in the supplied list of characters @cs@. Returns the parsed--- character.+-- 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, Token s ~ Char) => f Char -> m Char+noneOf :: (Foldable f, MonadParsec e s m)+  => f (Token s)+  -> m (Token s) noneOf cs = satisfy (`notElem` cs) {-# INLINE noneOf #-} --- | The same as 'noneOf', but case-insensitive.------ > consonant = noneOf' "aeiou" <?> "consonant"--noneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-noneOf' cs = satisfy (`notElemi` cs)-{-# INLINE noneOf' #-}---- | The parser @satisfy f@ succeeds for any character for which the+-- | The parser @'satisfy' f@ succeeds for any character for which the -- supplied function @f@ returns 'True'. Returns the character that is -- actually parsed. -- -- > digitChar = satisfy isDigit <?> "digit" -- > oneOf cs  = satisfy (`elem` cs) -satisfy :: (MonadParsec e s m, Token s ~ Char) => (Char -> Bool) -> m Char+satisfy :: 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 (E.singleton (Tokens (x:|[])), E.empty, E.empty)+        else Left (pure (Tokens (x:|[])), E.empty) {-# INLINE satisfy #-}  ---------------------------------------------------------------------------- -- Sequence of characters --- | @string s@ parses a sequence of characters given by @s@. Returns the+-- | @'string' s@ parses a sequence of characters given by @s@. Returns the -- parsed string (i.e. @s@). -- -- > divOrMod = string "div" <|> string "mod" -string :: (MonadParsec e s m, Token s ~ Char) => String -> m String+string :: MonadParsec e s m+  => Tokens s+  -> m (Tokens s) string = tokens (==) {-# INLINE string #-} @@ -390,27 +416,8 @@ -- >>> parseTest (string' "foobar") "foObAr" -- "foObAr" -string' :: (MonadParsec e s m, Token s ~ Char) => String -> m String-string' = tokens casei+string' :: (MonadParsec e s m, CI.FoldCase (Tokens s))+  => Tokens s+  -> m (Tokens s)+string' = tokens ((==) `on` CI.mk) {-# INLINE string' #-}--------------------------------------------------------------------------------- Helpers---- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toUpper x == toUpper y-{-# INLINE casei #-}---- | Case-insensitive 'elem'.--elemi :: Foldable f => Char -> f Char -> Bool-elemi = any . casei-{-# INLINE elemi #-}---- | Case-insensitive 'notElem'.--notElemi :: Foldable f => Char -> f Char -> Bool-notElemi c = not . elemi c-{-# INLINE notElemi #-}
+ Text/Megaparsec/Char/Lexer.hs view
@@ -0,0 +1,548 @@+-- |+-- Module      :  Text.Megaparsec.Char.Lexer+-- Copyright   :  © 2015–2017 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- 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.+--+-- This module is intended to be imported qualified:+--+-- > import qualified Text.Megaparsec.Char.Lexer as L+--+-- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer".++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++module Text.Megaparsec.Char.Lexer+  ( -- * White space+    space+  , lexeme+  , symbol+  , symbol'+  , skipLineComment+  , skipBlockComment+  , skipBlockCommentNested+    -- * Indentation+  , indentLevel+  , incorrectIndent+  , indentGuard+  , nonIndented+  , IndentOpt (..)+  , indentBlock+  , lineFold+    -- * Character and string literals+  , charLiteral+    -- * Numbers+  , decimal+  , octal+  , hexadecimal+  , scientific+  , float+  , signed )+where++import Control.Applicative+import Control.Monad (void)+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (listToMaybe, fromMaybe, isJust)+import Data.Proxy+import Data.Scientific (Scientific)+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++----------------------------------------------------------------------------+-- 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.+--+-- Parsing of white space is an important part of any parser. We propose a+-- convention where every lexeme parser assumes no spaces before the lexeme+-- and consumes all spaces after the lexeme; this is what the 'lexeme'+-- combinator does, and so it's enough to wrap every lexeme parser with+-- 'lexeme' to achieve this. Note that you'll need to call 'space' manually+-- to consume any white space before the first lexeme (i.e. at the beginning+-- of the file).++space :: MonadParsec e s m+  => m () -- ^ A parser for 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+-- 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 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)+  where+    p = C.string start+    n = C.string end+{-# INLINEABLE skipBlockComment #-}++-- | @'skipBlockCommentNested' start end@ skips possibly nested block+-- comment starting with @start@ and ending with @end@.+--+-- @since 5.0.0++skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char)+  => Tokens s          -- ^ Start of block comment+  -> Tokens s          -- ^ End of block comment+  -> m ()+skipBlockCommentNested start end = p >> void (manyTill e n)+  where+    e = skipBlockCommentNested start end <|> void C.anyChar+    p = C.string start+    n = C.string end+{-# INLINEABLE skipBlockCommentNested #-}++----------------------------------------------------------------------------+-- Indentation++-- | Return the current indentation level.+--+-- The function is a simple shortcut defined as:+--+-- > indentLevel = sourceColumn <$> getPosition+--+-- @since 4.3.0++indentLevel :: MonadParsec e s m => m Pos+indentLevel = sourceColumn <$> getPosition+{-# INLINEABLE indentLevel #-}++-- | Fail reporting incorrect indentation error. The error has attached+-- information:+--+--     * Desired ordering between reference level and actual level+--     * Reference indentation level+--     * Actual indentation level+--+-- @since 5.0.0++incorrectIndent :: MonadParsec e s m+  => 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+{-# INLINEABLE incorrectIndent #-}++-- | @'indentGuard' spaceConsumer ord ref@ first consumes all white space+-- (indentation) with @spaceConsumer@ parser, then it checks the column+-- position. Ordering between current indentation level and the reference+-- indentation level @ref@ should be @ord@, otherwise the parser fails. On+-- success the current column position is returned.+--+-- When you want to parse a block of indentation, first run this parser with+-- arguments like @'indentGuard' spaceConsumer 'GT' 'pos1'@—this will make+-- sure you have some indentation. Use returned value to check indentation+-- on every subsequent line according to syntax of your language.++indentGuard :: MonadParsec e s m+  => m ()              -- ^ How to consume indentation (white space)+  -> Ordering -- ^ Desired ordering between reference level and actual level+  -> Pos               -- ^ Reference indentation level+  -> m Pos             -- ^ Current column (indentation level)+indentGuard sc ord ref = do+  sc+  actual <- indentLevel+  if compare actual ref == ord+    then return actual+    else incorrectIndent ord ref actual+{-# INLINEABLE indentGuard #-}++-- | Parse a non-indented construction. This ensures that there is no+-- indentation before actual data. Useful, for example, as a wrapper for+-- top-level function definitions.+--+-- @since 4.3.0++nonIndented :: MonadParsec e s m+  => m ()              -- ^ How to consume indentation (white space)+  -> m a               -- ^ How to parse actual data+  -> m a+nonIndented sc p = indentGuard sc EQ pos1 *> p+{-# INLINEABLE nonIndented #-}++-- | The data type represents available behaviors for parsing of indented+-- tokens. This is used in 'indentBlock', which see.+--+-- @since 4.3.0++data IndentOpt m a b+  = IndentNone a+    -- ^ Parse no indented tokens, just return the value+  | IndentMany (Maybe Pos) ([b] -> m a) (m b)+    -- ^ Parse many indented tokens (possibly zero), use given indentation+    -- level (if 'Nothing', use level of the first indented token); the+    -- second argument tells how to get final result, and third argument+    -- describes how to parse an indented token+  | IndentSome (Maybe Pos) ([b] -> m a) (m b)+    -- ^ Just like 'IndentMany', but requires at least one indented token to+    -- be present++-- | Parse a “reference” token and a number of other tokens that have+-- greater (but the same) level of indentation than that of “reference”+-- token. Reference token can influence parsing, see 'IndentOpt' for more+-- information.+--+-- Tokens /must not/ consume newlines after them. On the other hand, the+-- first argument of this function /must/ consume newlines among other white+-- space characters.+--+-- @since 4.3.0++indentBlock :: (MonadParsec e s m, Token s ~ Char)+  => m ()              -- ^ How to consume indentation (white space)+  -> m (IndentOpt m a b) -- ^ How to parse “reference” token+  -> m a+indentBlock sc r = do+  sc+  ref <- indentLevel+  a   <- r+  case a of+    IndentNone x -> sc *> return x+    IndentMany indent f p -> do+      mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)+      done <- isJust <$> optional eof+      case (mlvl, done) of+        (Just lvl, False) ->+          indentedItems ref (fromMaybe lvl indent) sc p >>= f+        _ -> sc *> f []+    IndentSome indent f p -> do+      pos <- C.eol *> indentGuard sc GT ref+      let lvl = fromMaybe pos indent+      x <- if | pos <= ref -> incorrectIndent GT ref pos+              | pos == lvl -> p+              | otherwise  -> incorrectIndent EQ lvl pos+      xs  <- indentedItems ref lvl sc p+      f (x:xs)+{-# INLINEABLE indentBlock #-}++-- | Grab indented items. This is a helper for 'indentBlock', it's not a+-- part of the public API.++indentedItems :: MonadParsec e s m+  => Pos               -- ^ Reference indentation level+  -> Pos               -- ^ Level of the first indented item ('lookAhead'ed)+  -> m ()              -- ^ How to consume indentation (white space)+  -> m b               -- ^ How to parse indented tokens+  -> m [b]+indentedItems ref lvl sc p = go+  where+    go = do+      sc+      pos  <- indentLevel+      done <- isJust <$> optional eof+      if done+        then return []+        else if | pos <= ref -> return []+                | pos == lvl -> (:) <$> p <*> go+                | otherwise  -> incorrectIndent EQ lvl pos++-- | Create a parser that supports line-folding. The first argument is used+-- to consume white space between components of line fold, thus it /must/+-- consume newlines in order to work properly. The second argument is a+-- callback that receives a custom space-consuming parser as argument. This+-- parser should be used after separate components of line fold that can be+-- put on different lines.+--+-- An example should clarify the usage pattern:+--+-- > sc = L.space (void spaceChar) empty empty+-- >+-- > myFold = L.lineFold sc $ \sc' -> do+-- >   L.symbol sc' "foo"+-- >   L.symbol sc' "bar"+-- >   L.symbol sc  "baz" -- for the last symbol we use normal space consumer+--+-- @since 5.0.0++lineFold :: MonadParsec e s m+  => m ()              -- ^ How to consume indentation (white space)+  -> (m () -> m a)     -- ^ Callback that uses provided space-consumer+  -> m a+lineFold sc action =+  sc >> indentLevel >>= action . void . indentGuard sc GT+{-# INLINEABLE lineFold #-}++----------------------------------------------------------------------------+-- Character and string literals++-- | The lexeme parser parses a single literal character without quotes. The+-- purpose of this parser is to help with parsing of conventional escape+-- sequences. It's your responsibility to take care of character literal+-- syntax in your language (by surrounding it with single quotes or+-- similar).+--+-- The literal character is parsed according to the grammar rules defined in+-- the Haskell report.+--+-- Note that you can use this parser as a building block to parse various+-- string literals:+--+-- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"')+--+-- __Performance note__: the parser is not particularly efficient at the+-- moment.++charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char+charLiteral = label "literal character" $ do+  -- The @~@ is needed to avoid requiring a MonadFail constraint,+  -- and we do know that r will be non-empty if count' succeeds.+  ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar+  case listToMaybe (Char.readLitChar r) of+    Just (c, r') -> count (length r - length r') C.anyChar >> return c+    Nothing      -> unexpected (Tokens (x:|[]))+{-# INLINEABLE charLiteral #-}++----------------------------------------------------------------------------+-- Numbers++-- | Parse an integer in decimal representation according to the format of+-- integer literals described in the Haskell report.+--+-- If you need to parse signed integers, see 'signed' combinator.+--+-- __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+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_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit+  where+    mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a c = a * 10 + fromIntegral (Char.digitToInt c)++-- | Parse an integer in octal representation. Representation of octal+-- number is expected to be according to the Haskell report except for the+-- fact that this parser doesn't parse “0o” or “0O” prefix. It is a+-- responsibility of the programmer to parse correct prefix before parsing+-- the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > octal = char '0' >> char' 'o' >> L.octal+--+-- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it+-- wasn't polymorphic in its return type.++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"+  where+    mkNum    = 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+-- hexadecimal number is expected to be according to the Haskell report+-- except for the fact that this parser doesn't parse “0x” or “0X” prefix.+-- It is a responsibility of the programmer to parse correct prefix before+-- parsing the number itself.+--+-- For example you can make it conform to the Haskell report like this:+--+-- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal+--+-- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it+-- wasn't polymorphic in its return type.++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"+  where+    mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a c = a * 16 + fromIntegral (Char.digitToInt c)+{-# INLINEABLE hexadecimal #-}++-- | Parse a floating point value as a 'Scientific' number. 'Scientific' is+-- great for parsing of arbitrary precision numbers coming from an untrusted+-- source. See documentation in "Data.Scientific" for more information.+--+-- The parser can be used to parse integers or floating point values. Use+-- functions like 'Data.Scientific.floatingOrInteger' from "Data.Scientific"+-- to test and extract integer or real values.+--+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.+--+-- @since 5.0.0++scientific+  :: forall e s m. (MonadParsec e s m, Token s ~ Char)+  => m Scientific+scientific = do+  let pxy = Proxy :: Proxy s+  c' <- decimal_+  SP c e' <- option (SP c' 0) $ 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)+    mkNum <$> takeWhile1P (Just "digit") Char.isDigit+  e <- option e' $ do+    void (C.char' 'e')+    (+ e') <$> signed (return ()) decimal_+  return (Sci.scientific c e)+{-# INLINEABLE scientific #-}++data SP = SP !Integer {-# UNPACK #-} !Int++-- | Parse a floating point number without sign. There are differences+-- between the syntax for floating point literals described in the Haskell+-- report and what this function accepts. In particular, it does not require+-- fractional part and accepts inputs like @\"3\"@ returning @3.0@.+--+-- This is a simple short-cut defined as:+--+-- > float = Sci.toRealFloat <$> scientific <?> "floating point number"+--+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.+--+-- __Note__: before version 6.0.0 the function returned 'Double', i.e. it+-- wasn't polymorphic in its return type.++float :: (MonadParsec e s m, Token s ~ Char, RealFloat a) => m a+float = Sci.toRealFloat <$> scientific <?> "floating point number"+{-# INLINEABLE float #-}++-- | @'signed' space p@ parser parses an optional sign character (“+” or+-- “-”), then if there is a sign it consumes optional white space (using+-- @space@ parser), then it runs parser @p@ which should return a number.+-- Sign of the number is changed according to the previously parsed sign+-- character.+--+-- For example, to parse signed integer you can write:+--+-- > lexeme        = L.lexeme spaceConsumer+-- > integer       = lexeme L.decimal+-- > signedInteger = L.signed spaceConsumer integer++signed :: (MonadParsec e s m, Token s ~ 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 spc p = ($) <$> option id (lexeme spc sign) <*> p+  where+    sign = (id <$ C.char '+') <|> (negate <$ C.char '-')+{-# INLINEABLE signed #-}
− Text/Megaparsec/Combinator.hs 
@@ -1,181 +0,0 @@--- |--- Module      :  Text.Megaparsec.Combinator--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Commonly used generic combinators. Note that all the combinators work--- with 'Applicative' and 'Alternative' instances.--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}--module Text.Megaparsec.Combinator-  ( between-  , choice-  , count-  , count'-  , eitherP-  , endBy-  , endBy1-  , manyTill-  , someTill-  , option-  , sepBy-  , sepBy1-  , sepEndBy-  , sepEndBy1-  , skipMany-  , skipSome )-where--import Control.Applicative-import Control.Monad (void)-import Data.Foldable (asum)--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable)-import Data.Traversable (sequenceA)-#endif---- | @between open close p@ parses @open@, followed by @p@ and @close@.--- Returns the value returned by @p@.------ > braces = between (symbol "{") (symbol "}")--between :: Applicative m => m open -> m close -> m a -> m a-between open close p = open *> p <* close-{-# INLINE between #-}---- | @choice ps@ tries to apply the parsers in the list @ps@ in order, until--- one of them succeeds. Returns the value of the succeeding parser.--choice :: (Foldable f, Alternative m) => f (m a) -> m a-choice = asum-{-# INLINE choice #-}---- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal--- to zero, the parser equals to @return []@. Returns a list of @n@ values.--count :: Applicative m => Int -> m a -> m [a]-count n p = sequenceA (replicate n p)-{-# INLINE count #-}---- | @count' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is not--- positive or @m > n@, the parser equals to @return []@. Returns a list of--- parsed values.------ Please note that @m@ /may/ be negative, in this case effect is the same--- as if it were equal to zero.--count' :: Alternative m => Int -> Int -> m a -> m [a]-count' m' n' p = go m' n'-  where-    go !m !n-      | n <= 0 || m > n = pure []-      | m > 0           = (:) <$> p <*> go (m - 1) (n - 1)-      | otherwise       =-          let f t ts = maybe [] (:ts) t-          in f <$> optional p <*> go 0 (pred n)-{-# INLINE count' #-}---- | Combine two alternatives.------ @since 4.4.0--eitherP :: Alternative m => m a -> m b -> m (Either a b)-eitherP a b = (Left <$> a) <|> (Right <$> b)-{-# INLINE eitherP #-}---- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated and--- ended by @sep@. Returns a list of values returned by @p@.------ > cStatements = cStatement `endBy` semicolon--endBy :: Alternative m => m a -> m sep -> m [a]-endBy p sep = many (p <* sep)-{-# INLINE endBy #-}---- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated and--- ended by @sep@. Returns a list of values returned by @p@.--endBy1 :: Alternative m => m a -> m sep -> m [a]-endBy1 p sep = some (p <* sep)-{-# INLINE endBy1 #-}---- | @manyTill p end@ applies parser @p@ /zero/ or more times until parser--- @end@ succeeds. Returns the list of values returned by @p@. This parser--- can be used to scan comments:------ > simpleComment = string "<!--" >> manyTill anyChar (string "-->")--manyTill :: Alternative m => m a -> m end -> m [a]-manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go)-{-# INLINE manyTill #-}---- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should--- succeed at least once.--someTill :: Alternative m => m a -> m end -> m [a]-someTill p end = (:) <$> p <*> manyTill p end-{-# INLINE someTill #-}---- | @option x p@ tries to apply the parser @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value returned--- by @p@.------ > priority = option 0 (digitToInt <$> digitChar)--option :: Alternative m => a -> m a -> m a-option x p = p <|> pure x-{-# INLINE option #-}---- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated by--- @sep@. Returns a list of values returned by @p@.------ > commaSep p = p `sepBy` comma--sepBy :: Alternative m => m a -> m sep -> m [a]-sepBy p sep = sepBy1 p sep <|> pure []-{-# INLINE sepBy #-}---- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated by--- @sep@. Returns a list of values returned by @p@.--sepBy1 :: Alternative m => m a -> m sep -> m [a]-sepBy1 p sep = (:) <$> p <*> many (sep *> p)-{-# INLINE sepBy1 #-}---- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, separated--- and optionally ended by @sep@. Returns a list of values returned by @p@.--sepEndBy :: Alternative m => m a -> m sep -> m [a]-sepEndBy p sep = sepEndBy1 p sep <|> pure []-{-# INLINE sepEndBy #-}---- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, separated--- and optionally ended by @sep@. Returns a list of values returned by @p@.--sepEndBy1 :: Alternative m => m a -> m sep -> m [a]-sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])---- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping its--- result.------ > space = skipMany spaceChar--skipMany :: Alternative m => m a -> m ()-skipMany p = void $ many p-{-# INLINE skipMany #-}---- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping its--- result.--skipSome :: Alternative m => m a -> m ()-skipSome p = void $ some p-{-# INLINE skipSome #-}
Text/Megaparsec/Error.hs view
@@ -11,46 +11,62 @@ -- 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 CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Text.Megaparsec.Error-  ( ErrorItem (..)-  , ErrorComponent (..)-  , Dec (..)+  ( -- * Parse error type+    ErrorItem (..)+  , ErrorFancy (..)   , ParseError (..)+  , errorPos+    -- * Pretty-printing   , ShowToken (..)+  , LineToken (..)   , ShowErrorComponent (..)   , parseErrorPretty+  , parseErrorPretty'   , sourcePosStackPretty   , parseErrorTextPretty ) where  import Control.DeepSeq-import Control.Monad.Catch+import Control.Exception+import Data.Char (chr) import Data.Data (Data)-import Data.Foldable (concat) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromMaybe, isNothing)+import Data.Proxy import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable)+import Data.Void+import Data.Word (Word8) import GHC.Generics import Prelude hiding (concat)-import Test.QuickCheck hiding (label)+import Text.Megaparsec.Pos+import Text.Megaparsec.Stream import qualified Data.List.NonEmpty as NE import qualified Data.Set           as E -import Text.Megaparsec.Pos- #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif +----------------------------------------------------------------------------+-- Parse error type+ -- | Data type that is used to represent “unexpected\/expected” items in -- 'ParseError'. The data type is parametrized over the token type @t@. --@@ -60,92 +76,56 @@   = 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)+  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)  instance NFData t => NFData (ErrorItem t) -instance Arbitrary t => Arbitrary (ErrorItem t) where-  arbitrary = oneof-    [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)-    , return EndOfInput ]---- | The type class defines how to represent information about various--- exceptional situations. Data types that are used as custom data component--- in 'ParseError' must be instances of this type class.------ @since 5.0.0--class Ord e => ErrorComponent e where--  -- | Represent the message passed to 'fail' in parser monad.-  ---  -- @since 5.0.0--  representFail :: String -> e--  -- | Represent information about incorrect indentation.-  ---  -- @since 5.0.0--  representIndentation-    :: Ordering -- ^ Desired ordering between reference level and actual level-    -> Pos             -- ^ Reference indentation level-    -> Pos             -- ^ Actual indentation level-    -> e--instance ErrorComponent () where-  representFail _ = ()-  representIndentation _ _ _ = ()---- | “Default error component”. This is our instance of 'ErrorComponent'--- provided out-of-box.+-- | Additional error data, extendable by user. When no custom data is+-- necessary, the type is typically indexed by 'Void' to “cancel” the+-- 'ErrorCustom' constructor. ----- @since 5.0.0+-- @since 6.0.0 -data Dec-  = DecFail String         -- ^ 'fail' has been used in parser monad-  | DecIndentation Ordering Pos Pos+data ErrorFancy e+  = ErrorFail String+    -- ^ 'fail' has been used in parser monad+  | ErrorIndentation Ordering Pos Pos     -- ^ Incorrect indentation error: desired ordering between reference     -- level and actual level, reference indentation level, actual     -- indentation level-  deriving (Show, Read, Eq, Ord, Data, Typeable)--instance NFData Dec where-  rnf (DecFail str) = rnf str-  rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act--instance Arbitrary Dec where-  arbitrary = oneof-    [ sized (\n -> do-        k <- choose (0, n `div` 2)-        DecFail <$> vectorOf k arbitrary)-    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]+  | ErrorCustom e+    -- ^ Custom error data, can be conveniently disabled by indexing+    -- 'ErrorFancy' by 'Void'+  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) -instance ErrorComponent Dec where-  representFail        = DecFail-  representIndentation = DecIndentation+instance NFData a => NFData (ErrorFancy a) where+  rnf (ErrorFail str) = rnf str+  rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act+  rnf (ErrorCustom a) = rnf a --- | 'ParseError' represents… parse errors. It provides the stack of source--- positions, a set of expected and unexpected tokens as well as a set of--- custom associated data. The data type is parametrized over the token type--- @t@ and the custom data @e@.+-- | @'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. ----- 'Semigroup' (and 'Monoid') instance of the data type allows to merge--- parse errors from different branches of parsing. When merging two+-- 'Semigroup' and 'Monoid' instances of the data type allow to merge parse+-- errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same,--- custom data sets and collections of message items are combined.+-- custom data sets and collections of message items are combined. Note that+-- fancy errors take precedence over trivial errors in merging.+--+-- @since 6.0.0 -data ParseError t e = ParseError-  { errorPos        :: NonEmpty SourcePos -- ^ Stack of source positions-  , errorUnexpected :: Set (ErrorItem t)  -- ^ Unexpected items-  , errorExpected   :: Set (ErrorItem t)  -- ^ Expected items-  , errorCustom     :: Set e              -- ^ Associated data, if any-  } deriving (Show, Read, Eq, Data, Typeable, Generic)+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)  instance (NFData t, NFData e) => NFData (ParseError t e) @@ -154,36 +134,30 @@   {-# INLINE (<>) #-}  instance (Ord t, Ord e) => Monoid (ParseError t e) where-  mempty  = ParseError (initialPos "" :| []) E.empty E.empty E.empty+  mempty  = TrivialError (initialPos "" :| []) Nothing E.empty   mappend = (<>)   {-# INLINE mappend #-}  instance ( Show t-         , Typeable t          , Ord t          , ShowToken t+         , Typeable t          , Show e-         , Typeable e-         , ShowErrorComponent e )+         , ShowErrorComponent e+         , Typeable e )   => Exception (ParseError t e) where #if MIN_VERSION_base(4,8,0)   displayException = parseErrorPretty #endif -instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where-  arbitrary = ParseError-    <$> (NE.fromList . getNonEmpty <$> arbitrary)-#if MIN_VERSION_QuickCheck(2,8,2)-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary-#else-    <*> (E.fromList <$> arbitrary)-    <*> (E.fromList <$> arbitrary)-    <*> (E.fromList <$> arbitrary)-#endif+-- | Get position of given 'ParseError'.+--+-- @since 6.0.0 +errorPos :: ParseError t e -> NonEmpty SourcePos+errorPos (TrivialError p _ _) = p+errorPos (FancyError   p _)   = p+ -- | 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@@ -194,78 +168,79 @@   => ParseError t e   -> ParseError t e   -> ParseError t e-mergeError e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) =-  case pos1 `compare` pos2 of+mergeError e1 e2 =+  case errorPos e1 `compare` errorPos e2 of     LT -> e2-    EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2)+    EQ ->+      case (e1, e2) of+        (TrivialError s1 u1 p1, TrivialError _ u2 p2) ->+          TrivialError s1 (n u1 u2) (E.union p1 p2)+        (FancyError {}, TrivialError {}) -> e1+        (TrivialError {}, FancyError {}) -> e2+        (FancyError s1 x1, FancyError _ x2) ->+          FancyError s1 (E.union x1 x2)     GT -> e1+  where+    -- NOTE The logic behind this merging is that since we only combine+    -- parse errors that happen at exactly the same position, all the+    -- unexpected items will be prefixes of input stream at that position or+    -- labels referring to the same thing. Our aim here is to choose the+    -- longest prefix (merging with labels and end of input is somewhat+    -- arbitrary, but is necessary because otherwise we can't make+    -- ParseError lawful Monoid and have nice parse errors at the same+    -- time).+    n Nothing  Nothing = Nothing+    n (Just x) Nothing = Just x+    n Nothing (Just y) = Just y+    n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} +----------------------------------------------------------------------------+-- 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.+--+-- @since 5.0.0  class ShowToken a where    -- | Pretty-print non-empty stream of tokens. This function is also used   -- to print single tokens (represented as singleton lists).-  ---  -- @since 5.0.0    showTokens :: NonEmpty a -> String  instance ShowToken Char where   showTokens = stringPretty --- | @stringPretty s@ returns pretty representation of string @s@. This is--- used when printing string tokens in error messages.+instance ShowToken Word8 where+  showTokens = stringPretty . fmap (chr . fromIntegral) -stringPretty :: NonEmpty Char -> String-stringPretty (x:|[])      = charPretty x-stringPretty ('\r':|"\n") = "crlf newline"-stringPretty xs           = "\"" ++ NE.toList xs ++ "\""+-- | Type class for tokens that support operations necessary for selecting+-- and displaying relevant line of input.+--+-- @since 6.0.0 --- | @charPretty ch@ returns user-friendly string representation of given--- character @ch@, suitable for using in error messages.+class LineToken a where -charPretty :: Char -> String-charPretty '\NUL' = "null (control character)"-charPretty '\SOH' = "start of heading (control character)"-charPretty '\STX' = "start of text (control character)"-charPretty '\ETX' = "end of text (control character)"-charPretty '\EOT' = "end of transmission (control character)"-charPretty '\ENQ' = "enquiry (control character)"-charPretty '\ACK' = "acknowledge (control character)"-charPretty '\BEL' = "bell (control character)"-charPretty '\BS'  = "backspace"-charPretty '\t'   = "tab"-charPretty '\n'   = "newline"-charPretty '\v'   = "vertical tab"-charPretty '\f'   = "form feed (control character)"-charPretty '\r'   = "carriage return"-charPretty '\SO'  = "shift out (control character)"-charPretty '\SI'  = "shift in (control character)"-charPretty '\DLE' = "data link escape (control character)"-charPretty '\DC1' = "device control one (control character)"-charPretty '\DC2' = "device control two (control character)"-charPretty '\DC3' = "device control three (control character)"-charPretty '\DC4' = "device control four (control character)"-charPretty '\NAK' = "negative acknowledge (control character)"-charPretty '\SYN' = "synchronous idle (control character)"-charPretty '\ETB' = "end of transmission block (control character)"-charPretty '\CAN' = "cancel (control character)"-charPretty '\EM'  = "end of medium (control character)"-charPretty '\SUB' = "substitute (control character)"-charPretty '\ESC' = "escape (control character)"-charPretty '\FS'  = "file separator (control character)"-charPretty '\GS'  = "group separator (control character)"-charPretty '\RS'  = "record separator (control character)"-charPretty '\US'  = "unit separator (control character)"-charPretty '\DEL' = "delete (control character)"-charPretty ' '    = "space"-charPretty '\160' = "non-breaking space"-charPretty x    = "'" ++ [x] ++ "'"+  -- | 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'++instance LineToken Word8 where+  tokenAsChar = chr . fromIntegral+  tokenIsNewline x = x == 10+ -- | The type class defines how to print custom data component of -- 'ParseError'. --@@ -282,44 +257,167 @@   showErrorComponent (Label label) = NE.toList label   showErrorComponent EndOfInput    = "end of input" -instance ShowErrorComponent Dec where-  showErrorComponent (DecFail msg) = msg-  showErrorComponent (DecIndentation ord ref actual) =-    "incorrect indentation (got " ++ show (unPos actual) ++-    ", should be " ++ p ++ show (unPos ref) ++ ")"-    where p = case ord of-                LT -> "less than "-                EQ -> "equal to "-                GT -> "greater than "+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 +instance ShowErrorComponent Void where+  showErrorComponent = absurd+ -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. ----- The function is defined as:------ > parseErrorPretty e =--- >   sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e--- -- @since 5.0.0 -parseErrorPretty :: ( Ord t-                    , ShowToken t-                    , ShowErrorComponent e )+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+  sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty 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.+--+-- @since 6.0.0++parseErrorPretty'+  :: forall s e.+     ( 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' s e =+  sourcePosStackPretty (errorPos e) <> ":\n" <>+    padding <> "|\n" <>+    lineNumber <> " | " <> rline <> "\n" <>+    padding <> "| " <> rpadding <> "^\n" <>+    parseErrorTextPretty e+  where+    epos       = NE.last (errorPos e)+    lineNumber = (show . unPos . sourceLine) epos+    padding    = replicate (length lineNumber + 1) ' '+    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '+    rline      =+      case rline' of+        [] -> "<empty line>"+        xs -> xs+    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $+      selectLine (sourceLine epos) s+ -- | Pretty-print a stack of source positions. -- -- @since 5.0.0  sourcePosStackPretty :: NonEmpty SourcePos -> String-sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos-  where (pos :| rest') = ms-        rest           = reverse rest'-        f p = "in file included from " ++ sourcePosPretty p ++ ",\n"+sourcePosStackPretty ms = mconcat (f <$> rest) <> sourcePosPretty pos+  where+    (pos :| rest') = ms+    rest           = reverse rest'+    f p = "in file included from " <> sourcePosPretty p <> ",\n" +-- | Pretty-print a textual part of a 'ParseError', that is, everything+-- except stack of source positions. The rendered staring always ends with a+-- new line.+--+-- @since 5.1.0++parseErrorTextPretty+  :: ( Ord t+     , ShowToken t+     , ShowErrorComponent e )+  => ParseError t e    -- ^ Parse error to render+  -> String            -- ^ Result of rendering+parseErrorTextPretty (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+parseErrorTextPretty (FancyError _ xs) =+  if E.null xs+    then "unknown fancy parse error\n"+    else unlines (showErrorComponent <$> 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)++-- | If the given character has a pretty representation, return that,+-- otherwise 'Nothing'. This is an internal helper.++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+ -- | Transforms a list of error messages into their textual representation.  messageItemsPretty :: ShowErrorComponent a@@ -330,31 +428,31 @@   | E.null ts = ""   | otherwise =     let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent-    in prefix ++ f ts ++ "\n"+    in prefix <> f 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+orList (x:|[y]) = x <> " or " <> y+orList xs       = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs --- | Pretty-print a textual part of a 'ParseError', that is, everything--- except stack of source positions. The rendered staring always ends with a--- new line.------ @since 5.1.0+-- | Select a line from input stream given its number. -parseErrorTextPretty :: ( Ord t-                        , ShowToken t-                        , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorTextPretty (ParseError _ us ps xs) =-  if E.null us && E.null ps && E.null xs-    then "unknown parse error\n"-    else concat-      [ messageItemsPretty "unexpected " us-      , messageItemsPretty "expecting "  ps-      , unlines (showErrorComponent <$> E.toAscList xs) ]+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'
+ Text/Megaparsec/Error/Builder.hs view
@@ -0,0 +1,212 @@+-- |+-- Module      :  Text.Megaparsec.Error.Builder+-- Copyright   :  © 2015–2017 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- A set of helpers that should make construction of 'ParseError's more+-- concise. This is primarily useful in test suites and for debugging, you+-- most certainly don't need it for normal usage.+--+-- @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+    -- * Error components+  , utok+  , utoks+  , ulabel+  , ueof+  , etok+  , etoks+  , elabel+  , eeof+  , fancy+    -- * Data types+  , ET+  , EF )+where++import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+import Data.Semigroup+import Data.Set (Set)+import Data.Typeable (Typeable)+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++----------------------------------------------------------------------------+-- Data types++-- | Auxiliary type for construction of trivial parse errors.++data ET t = ET (Maybe (ErrorItem t)) (Set (ErrorItem t))+  deriving (Eq, Ord, Data, Typeable, Generic)++instance Ord t => Semigroup (ET t) where+  ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1)+    where+      n Nothing  Nothing = Nothing+      n (Just x) Nothing = Just x+      n Nothing (Just y) = Just y+      n (Just x) (Just y) = Just (max x y)++instance Ord t => Monoid (ET t) 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)++instance Ord e => Semigroup (EF e) where+  EF xs0 <> EF xs1 = EF (E.union xs0 xs1)++instance Ord e => Monoid (EF e) where+  mempty  = EF E.empty+  mappend = (<>)++----------------------------------------------------------------------------+-- Top-level helpers++-- | Assemble a 'ParseError' from 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++-- | 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 :| []++----------------------------------------------------------------------------+-- Error components++-- | Construct an “unexpected token” error component.++utok :: Ord t => t -> ET t+utok = unexp . Tokens . nes++-- | Construct an “unexpected tokens” error component. Empty string produces+-- 'EndOfInput'.++utoks :: Ord t => [t] -> ET t+utoks = unexp . canonicalizeTokens++-- | 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++-- | Construct an “unexpected end of input” error component.++ueof :: Ord t => ET t+ueof = unexp EndOfInput++-- | Construct an “expected token” error component.++etok :: Ord t => t -> ET t+etok = expe . Tokens . nes++-- | Construct an “expected tokens” error component. Empty string produces+-- 'EndOfInput'.++etoks :: Ord t => [t] -> ET t+etoks = expe . canonicalizeTokens++-- | Construct an “expected label” error component. Do not use with empty+-- strings.++elabel :: Ord t => String -> ET t+elabel = expe . Label . NE.fromList++-- | Construct an “expected end of input” error component.++eeof :: Ord t => ET t+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+    Nothing -> EndOfInput+    Just xs -> Tokens xs++-- | Lift an unexpected item into 'ET'.++unexp :: ErrorItem t -> ET t+unexp u = ET (pure u) E.empty++-- | Lift an expected item into 'ET'.++expe :: ErrorItem t -> ET t+expe p = ET Nothing (E.singleton p)++-- | Make a singleton non-empty list from a value.++nes :: a -> NonEmpty a+nes x = x :| []
Text/Megaparsec/Expr.hs view
@@ -17,10 +17,7 @@   , makeExprParser ) where -import Control.Applicative ((<|>))--import Text.Megaparsec.Combinator-import Text.Megaparsec.Prim+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@@ -33,7 +30,7 @@   | Prefix  (m (a -> a))      -- ^ Prefix   | Postfix (m (a -> a))      -- ^ Postfix --- | @makeExprParser term table@ builds an expression parser for terms+-- | @'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. --@@ -56,11 +53,11 @@ -- -- If you want to have an operator that is a prefix of another operator in -- the table, use the following (or similar) wrapper instead of plain--- 'symbol':+-- 'Text.Megaparsec.Char.Lexer.symbol': -- -- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) ----- @makeExprParser@ takes care of all the complexity involved in building an+-- '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: --@@ -85,6 +82,7 @@   -> [[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@.
− Text/Megaparsec/Lexer.hs 
@@ -1,498 +0,0 @@--- |--- Module      :  Text.Megaparsec.Lexer--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ 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.------ This module is intended to be imported qualified:------ > import qualified Text.Megaparsec.Lexer as L--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf       #-}-{-# LANGUAGE TypeFamilies     #-}--module Text.Megaparsec.Lexer-  ( -- * White space-    space-  , lexeme-  , symbol-  , symbol'-  , skipLineComment-  , skipBlockComment-  , skipBlockCommentNested-    -- * Indentation-  , indentLevel-  , incorrectIndent-  , indentGuard-  , nonIndented-  , IndentOpt (..)-  , indentBlock-  , lineFold-    -- * Character and string literals-  , charLiteral-    -- * Numbers-  , integer-  , decimal-  , hexadecimal-  , octal-  , scientific-  , float-  , number-  , signed )-where--import Control.Applicative-import Control.Monad (void)-import Data.Char (readLitChar)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (listToMaybe, fromMaybe, isJust)-import Data.Scientific (Scientific, toRealFloat)-import qualified Data.Set as E--import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import qualified Text.Megaparsec.Char as C--------------------------------------------------------------------------------- White space---- | @space spaceChar lineComment blockComment@ produces parser that can--- parse white space in general. It's expected that you create such a parser--- once and pass it to other functions in this module as needed (when you--- see @spaceConsumer@ in documentation, usually it means that something--- like 'space' is expected there).------ @spaceChar@ is used to parse trivial space characters. You can use--- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as--- your own parser (if you don't want to automatically consume newlines, for--- example).------ @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' if you don't need anything special.------ Parsing of white space is an important part of any parser. We propose a--- convention where every lexeme parser assumes no spaces before the lexeme--- and consumes all spaces after the lexeme; this is what the 'lexeme'--- combinator does, and so it's enough to wrap every lexeme parser with--- 'lexeme' to achieve this. Note that you'll need to call 'space' manually--- to consume any white space before the first lexeme (i.e. at the beginning--- of the file).--space :: MonadParsec e s m-  => m () -- ^ A parser for a space character (e.g. @'void' 'C.spaceChar'@)-  -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')-  -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')-  -> m ()-space ch line block = hidden . skipMany $ choice [ch, line, block]---- | 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.integer--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---- | 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, Token s ~ Char)-  => m ()              -- ^ How to consume white space after lexeme-  -> String            -- ^ String to parse-  -> m String-symbol spc = lexeme spc . C.string---- | Case-insensitive version of 'symbol'. This may be helpful if you're--- working with case-insensitive languages.--symbol' :: (MonadParsec e s m, Token s ~ Char)-  => m ()              -- ^ How to consume white space after lexeme-  -> String            -- ^ String to parse (case-insensitive)-  -> m String-symbol' spc = lexeme spc . C.string'---- | Given comment prefix this function returns a parser that skips line--- comments. Note that it stops just before the newline character but--- doesn't consume the newline. Newline is either supposed to be consumed by--- 'space' parser or picked up manually.--skipLineComment :: (MonadParsec e s m, Token s ~ Char)-  => String            -- ^ Line comment prefix-  -> m ()-skipLineComment prefix = p >> void (manyTill C.anyChar n)-  where p = C.string prefix-        n = lookAhead (void C.newline) <|> eof---- | @skipBlockComment start end@ skips non-nested block comment starting--- with @start@ and ending with @end@.--skipBlockComment :: (MonadParsec e s m, Token s ~ Char)-  => String            -- ^ Start of block comment-  -> String            -- ^ End of block comment-  -> m ()-skipBlockComment start end = p >> void (manyTill C.anyChar n)-  where p = C.string start-        n = C.string end---- | @skipBlockCommentNested start end@ skips possibly nested block comment--- starting with @start@ and ending with @end@.------ @since 5.0.0--skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char)-  => String            -- ^ Start of block comment-  -> String            -- ^ End of block comment-  -> m ()-skipBlockCommentNested start end = p >> void (manyTill e n)-  where e = skipBlockCommentNested start end <|> void C.anyChar-        p = C.string start-        n = C.string end--------------------------------------------------------------------------------- Indentation---- | Return the current indentation level.------ The function is a simple shortcut defined as:------ > indentLevel = sourceColumn <$> getPosition------ @since 4.3.0--indentLevel :: MonadParsec e s m => m Pos-indentLevel = sourceColumn <$> getPosition---- | Fail reporting incorrect indentation error. The error has attached--- information:------     * Desired ordering between reference level and actual level---     * Reference indentation level---     * Actual indentation level------ @since 5.0.0--incorrectIndent :: MonadParsec e s m-  => Ordering  -- ^ Desired ordering between reference level and actual level-  -> Pos               -- ^ Reference indentation level-  -> Pos               -- ^ Actual indentation level-  -> m a-incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x)-  where x = representIndentation ord ref actual---- | @indentGuard spaceConsumer ord ref@ first consumes all white space--- (indentation) with @spaceConsumer@ parser, then it checks the column--- position. Ordering between current indentation level and the reference--- indentation level @ref@ should be @ord@, otherwise the parser fails. On--- success the current column position is returned.------ When you want to parse a block of indentation, first run this parser with--- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@—this will--- make sure you have some indentation. Use returned value to check--- indentation on every subsequent line according to syntax of your--- language.--indentGuard :: MonadParsec e s m-  => m ()              -- ^ How to consume indentation (white space)-  -> Ordering -- ^ Desired ordering between reference level and actual level-  -> Pos               -- ^ Reference indentation level-  -> m Pos             -- ^ Current column (indentation level)-indentGuard sc ord ref = do-  sc-  actual <- indentLevel-  if compare actual ref == ord-    then return actual-    else incorrectIndent ord ref actual---- | Parse a non-indented construction. This ensures that there is no--- indentation before actual data. Useful, for example, as a wrapper for--- top-level function definitions.------ @since 4.3.0--nonIndented :: MonadParsec e s m-  => m ()              -- ^ How to consume indentation (white space)-  -> m a               -- ^ How to parse actual data-  -> m a-nonIndented sc p = indentGuard sc EQ (unsafePos 1) *> p---- | The data type represents available behaviors for parsing of indented--- tokens. This is used in 'indentBlock', which see.------ @since 4.3.0--data IndentOpt m a b-  = IndentNone a-    -- ^ Parse no indented tokens, just return the value-  | IndentMany (Maybe Pos) ([b] -> m a) (m b)-    -- ^ Parse many indented tokens (possibly zero), use given indentation-    -- level (if 'Nothing', use level of the first indented token); the-    -- second argument tells how to get final result, and third argument-    -- describes how to parse an indented token-  | IndentSome (Maybe Pos) ([b] -> m a) (m b)-    -- ^ Just like 'IndentMany', but requires at least one indented token to-    -- be present---- | Parse a “reference” token and a number of other tokens that have--- greater (but the same) level of indentation than that of “reference”--- token. Reference token can influence parsing, see 'IndentOpt' for more--- information.------ Tokens /must not/ consume newlines after them. On the other hand, the--- first argument of this function /must/ consume newlines among other white--- space characters.------ @since 4.3.0--indentBlock :: (MonadParsec e s m, Token s ~ Char)-  => m ()              -- ^ How to consume indentation (white space)-  -> m (IndentOpt m a b) -- ^ How to parse “reference” token-  -> m a-indentBlock sc r = do-  sc-  ref <- indentLevel-  a   <- r-  case a of-    IndentNone x -> sc *> return x-    IndentMany indent f p -> do-      mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)-      done <- isJust <$> optional eof-      case (mlvl, done) of-        (Just lvl, False) ->-          indentedItems ref (fromMaybe lvl indent) sc p >>= f-        _ -> sc *> f []-    IndentSome indent f p -> do-      lvl <- C.eol *> indentGuard sc GT ref-      x   <- p-      xs  <- indentedItems ref (fromMaybe lvl indent) sc p-      f (x:xs)---- | Grab indented items. This is a helper for 'indentBlock', it's not a--- part of the public API.--indentedItems :: MonadParsec e s m-  => Pos               -- ^ Reference indentation level-  -> Pos               -- ^ Level of the first indented item ('lookAhead'ed)-  -> m ()              -- ^ How to consume indentation (white space)-  -> m b               -- ^ How to parse indented tokens-  -> m [b]-indentedItems ref lvl sc p = go-  where-    go = do-      sc-      pos  <- indentLevel-      done <- isJust <$> optional eof-      if done-        then return []-        else if | pos <= ref -> return []-                | pos == lvl -> (:) <$> p <*> go-                | otherwise  -> incorrectIndent EQ lvl pos---- | Create a parser that supports line-folding. The first argument is used--- to consume white space between components of line fold, thus it /must/--- consume newlines in order to work properly. The second argument is a--- callback that receives a custom space-consuming parser as argument. This--- parser should be used after separate components of line fold that can be--- put on different lines.------ An example should clarify the usage pattern:------ > sc = L.space (void spaceChar) empty empty--- >--- > myFold = L.lineFold sc $ \sc' -> do--- >   L.symbol sc' "foo"--- >   L.symbol sc' "bar"--- >   L.symbol sc  "baz" -- for the last symbol we use normal space consumer------ @since 5.0.0--lineFold :: MonadParsec e s m-  => m ()              -- ^ How to consume indentation (white space)-  -> (m () -> m a)     -- ^ Callback that uses provided space-consumer-  -> m a-lineFold sc action =-  sc >> indentLevel >>= action . void . indentGuard sc GT--------------------------------------------------------------------------------- Character and string literals---- | The lexeme parser parses a single literal character without quotes. The--- purpose of this parser is to help with parsing of conventional escape--- sequences. It's your responsibility to take care of character literal--- syntax in your language (by surrounding it with single quotes or--- similar).------ The literal character is parsed according to the grammar rules defined in--- the Haskell report.------ Note that you can use this parser as a building block to parse various--- string literals:------ > stringLiteral = char '"' >> manyTill L.charLiteral (char '"')------ If you want to write @stringLiteral@ that adheres to the Haskell report--- though, you'll need to take care of the @\\&@ combination which is not a--- character, but can be used to separate characters (as in @\"\\291\\&4\"@--- which is two characters long):------ > stringLiteral = catMaybes <$> (char '"' >> manyTill ch (char '"'))--- >   where ch = (Just <$> L.charLiteral) <|> (Nothing <$ string "\\&")--charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char-charLiteral = label "literal character" $ do-  -- The @~@ is needed to avoid requiring a MonadFail constraint,-  -- and we do know that r will be non-empty if count' succeeds.-  ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar-  case listToMaybe (readLitChar r) of-    Just (c, r') -> count (length r - length r') C.anyChar >> return c-    Nothing      -> unexpected (Tokens (x:|[]))--------------------------------------------------------------------------------- Numbers---- | Parse an integer without sign in decimal representation (according to--- the format of integer literals described in the Haskell report).------ If you need to parse signed integers, see 'signed' combinator.--integer :: (MonadParsec e s m, Token s ~ Char) => m Integer-integer = decimal <?> "integer"---- | The same as 'integer', but 'integer' is 'label'ed with “integer” label,--- while this parser is labeled with “decimal integer”.--decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer-decimal = nump "" C.digitChar <?> "decimal integer"---- | Parse an integer in hexadecimal representation. Representation of--- hexadecimal number is expected to be according to the Haskell report--- except for the fact that this parser doesn't parse “0x” or “0X” prefix.--- It is a responsibility of the programmer to parse correct prefix before--- parsing the number itself.------ For example you can make it conform to Haskell report like this:------ > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal--hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer-hexadecimal = nump "0x" C.hexDigitChar <?> "hexadecimal integer"---- | Parse an integer in octal representation. Representation of octal--- number is expected to be according to the Haskell report except for the--- fact that this parser doesn't parse “0o” or “0O” prefix. It is a--- responsibility of the programmer to parse correct prefix before parsing--- the number itself.--octal :: (MonadParsec e s m, Token s ~ Char) => m Integer-octal = nump "0o" C.octDigitChar <?> "octal integer"---- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then--- prepends @prefix@ to returned value and tries to interpret the result as--- an integer according to Haskell syntax.--nump :: MonadParsec e s m => String -> m Char -> m Integer-nump prefix baseDigit = read . (prefix ++) <$> some baseDigit---- | Parse a floating point value as a 'Scientific' number. 'Scientific' is--- great for parsing of arbitrary precision numbers coming from an untrusted--- source. See documentation in "Data.Scientific" for more information.--- Representation of the floating point value is expected to be according to--- the Haskell report.------ This function does not parse sign, if you need to parse signed numbers,--- see 'signed'.------ @since 5.0.0--scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific-scientific = label "floating point number" (read <$> f)-  where f = (++) <$> some C.digitChar <*> (fraction <|> fExp)---- | Parse a floating point number without sign. This is a simple shortcut--- defined as:------ > float = toRealFloat <$> scientific--float :: (MonadParsec e s m, Token s ~ Char) => m Double-float = toRealFloat <$> scientific---- | This is a helper for 'float' parser. It parses fractional part of--- floating point number, that is, dot and everything after it.--fraction :: (MonadParsec e s m, Token s ~ Char) => m String-fraction = do-  void (C.char '.')-  d <- some C.digitChar-  e <- option "" fExp-  return ('.' : d ++ e)---- | This helper parses exponent of floating point numbers.--fExp :: (MonadParsec e s m, Token s ~ Char) => m String-fExp = do-  expChar <- C.char' 'e'-  signStr <- option "" (pure <$> choice (C.char <$> "+-"))-  d       <- some C.digitChar-  return (expChar : signStr ++ d)---- | Parse a number: either integer or floating point. The parser can handle--- overlapping grammars graciously. Use functions like--- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and--- extract integer or real values.--number :: (MonadParsec e s m, Token s ~ Char) => m Scientific-number = label "number" (read <$> f)-  where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp)---- | @signed space p@ parser parses an optional sign, then if there is a--- sign it will consume optional white space (using @space@ parser), then it--- runs parser @p@ which should return a number. Sign of the number is--- changed according to previously parsed sign.------ For example, to parse signed integer you can write:------ > lexeme        = L.lexeme spaceConsumer--- > integer       = lexeme L.integer--- > signedInteger = L.signed spaceConsumer integer--signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a-signed spc p = ($) <$> option id (lexeme spc sign) <*> p---- | Parse a sign and return either 'id' or 'negate' according to parsed--- sign.--sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a)-sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate)
Text/Megaparsec/Perm.hs view
@@ -26,8 +26,7 @@   , (<|?>) ) where -import Text.Megaparsec.Combinator (choice)-import Text.Megaparsec.Prim+import Text.Megaparsec  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>))
Text/Megaparsec/Pos.hs view
@@ -10,90 +10,83 @@ -- 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.+--+-- 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 #-}-{-# LANGUAGE TupleSections              #-}  module Text.Megaparsec.Pos   ( -- * Abstract position     Pos   , mkPos   , unPos-  , unsafePos+  , pos1+  , defaultTabWidth   , InvalidPosException (..)     -- * Source position   , SourcePos (..)   , initialPos-  , sourcePosPretty-    -- * Helpers implementing default behaviors-  , defaultUpdatePos-  , defaultTabWidth )+  , sourcePosPretty ) where  import Control.DeepSeq-import Control.Monad.Catch+import Control.Exception import Data.Data (Data) import Data.Semigroup import Data.Typeable (Typeable) import GHC.Generics-import Test.QuickCheck -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Word (Word)-#endif- ---------------------------------------------------------------------------- -- Abstract position --- | Positive integer that is used to represent line number, column number,--- and similar things like indentation level. 'Semigroup' instance can be--- used to safely and purely add 'Pos'es together.+-- | 'Pos' is the type for positive integers. This is used to represent line+-- number, column number, and similar things like indentation level.+-- 'Semigroup' instance can be used to safely and efficiently add 'Pos'es+-- together. -- -- @since 5.0.0 -newtype Pos = Pos Word+newtype Pos = Pos Int   deriving (Show, Eq, Ord, Data, Typeable, NFData) -instance Arbitrary Pos where-  arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))---- | Construction of 'Pos' from an instance of 'Integral'. The function--- throws 'InvalidPosException' when given non-positive argument. Note that--- the function is polymorphic with respect to 'MonadThrow' @m@, so you can--- get result inside of 'Maybe', for example.+-- | Construction of 'Pos' from 'Int'. The function throws+-- 'InvalidPosException' when given a non-positive argument. ----- @since 5.0.0+-- @since 6.0.0 -mkPos :: (Integral a, MonadThrow m) => a -> m Pos-mkPos x =-  if x < 1-    then throwM InvalidPosException-    else (return . Pos . fromIntegral) x+mkPos :: Int -> Pos+mkPos a =+  if a <= 0+    then throw (InvalidPosException a)+    else Pos a {-# INLINE mkPos #-} --- | Dangerous construction of 'Pos'. Use when you know for sure that--- argument is positive.+-- | Extract 'Int' from 'Pos'. ----- @since 5.0.0+-- @since 6.0.0 -unsafePos :: Word -> Pos-unsafePos x =-  if x < 1-    then error "Text.Megaparsec.Pos.unsafePos"-    else Pos x-{-# INLINE unsafePos #-}+unPos :: Pos -> Int+unPos (Pos w) = w+{-# INLINE unPos #-} --- | Extract 'Word' from 'Pos'.+-- | Position with value 1. --+-- @since 6.0.0++pos1 :: Pos+pos1 = mkPos 1++-- | Value of tab width used by default. Always prefer this constant when+-- you want to refer to the default tab width because actual value /may/+-- change in future.+-- -- @since 5.0.0 -unPos :: Pos -> Word-unPos (Pos w) = w-{-# INLINE unPos #-}+defaultTabWidth :: Pos+defaultTabWidth = mkPos 8  instance Semigroup Pos where   (Pos x) <> (Pos y) = Pos (x + y)@@ -104,22 +97,16 @@     readParen (d > 10) $ \r1 -> do       ("Pos", r2) <- lex r1       (x,     r3) <- readsPrec 11 r2-      (,r3) <$> mkPos (x :: Integer)--instance Arbitrary SourcePos where-  arbitrary = SourcePos-    <$> sized (\n -> do-          k <- choose (0, n `div` 2)-          vectorOf k arbitrary)-    <*> (unsafePos <$> choose (1, 1000))-    <*> (unsafePos <$> choose (1,  100))+      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+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)  instance Exception InvalidPosException@@ -128,7 +115,7 @@ ---------------------------------------------------------------------------- -- Source position --- | The data type @SourcePos@ represents source positions. It contains the+-- | The data type 'SourcePos' represents source positions. It contains the -- name of the source file, a line number, and a column number. Source line -- and column positions change intensively during parsing, so we need to -- make them strict to avoid memory leaks.@@ -144,10 +131,8 @@ -- | Construct initial position (line 1, column 1) given name of source -- file. -initialPos :: String -> SourcePos-initialPos n = SourcePos n u u-  where u = unsafePos 1-{-# INLINE initialPos #-}+initialPos :: FilePath -> SourcePos+initialPos n = SourcePos n pos1 pos1  -- | Pretty-print a 'SourcePos'. --@@ -156,39 +141,6 @@ sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c)   | null n    = showLC-  | otherwise = n ++ ":" ++ showLC-  where showLC = show (unPos l) ++ ":" ++ show (unPos c)--------------------------------------------------------------------------------- Helpers implementing default behaviors---- | Update a source position given a character. The first argument--- specifies the tab width. If the character is a newline (\'\\n\') the line--- number is incremented by 1. If the character is a tab (\'\\t\') the--- column number is incremented to the nearest tab position. In all other--- cases, the column is incremented by 1.------ @since 5.0.0--defaultUpdatePos-  :: Pos               -- ^ Tab width-  -> SourcePos         -- ^ Current position-  -> Char              -- ^ Current token-  -> (SourcePos, SourcePos) -- ^ Actual position and incremented position-defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos)+  | otherwise = n <> ":" <> showLC   where-    u = unsafePos 1-    w = unPos width-    c' = unPos c-    npos =-      case ch of-        '\n' -> SourcePos n (l <> u) u-        '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w))-        _    -> SourcePos n l (c <> u)---- | Value of tab width used by default. Always prefer this constant when--- you want to refer to the default tab width because actual value /may/--- change in future.--defaultTabWidth :: Pos-defaultTabWidth = unsafePos 8+    showLC = show (unPos l) <> ":" <> show (unPos c)
− Text/Megaparsec/Prim.hs 
@@ -1,1410 +0,0 @@--- |--- Module      :  Text.Megaparsec.Prim--- Copyright   :  © 2015–2017 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ The primitive parser combinators.--{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# OPTIONS_HADDOCK not-home            #-}--module Text.Megaparsec.Prim-  ( -- * Data types-    State (..)-  , Stream (..)-  , Parsec-  , ParsecT-    -- * Primitive combinators-  , MonadParsec (..)-  , (<?>)-  , unexpected-  , match-  , region-    -- * Parser state combinators-  , getInput-  , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , setParserState-    -- * Running parser-  , parse-  , parseMaybe-  , parseTest-  , runParser-  , runParser'-  , runParserT-  , runParserT'-    -- * Debugging-  , dbg )-where--import Control.DeepSeq-import Control.Monad-import Control.Monad.Cont.Class-import Control.Monad.Error.Class-import Control.Monad.Identity-import Control.Monad.Reader.Class-import Control.Monad.State.Class hiding (state)-import Control.Monad.Trans-import Control.Monad.Trans.Identity-import Data.Data (Data)-import Data.Foldable (foldl')-import Data.List (genericTake)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid hiding ((<>))-import Data.Proxy-import Data.Semigroup-import Data.Set (Set)-import Data.Typeable (Typeable)-import Debug.Trace-import GHC.Generics-import Prelude hiding (all)-import Test.QuickCheck hiding (Result (..), label)-import qualified Control.Applicative               as A-import qualified Control.Monad.Fail                as Fail-import qualified Control.Monad.RWS.Lazy            as L-import qualified Control.Monad.RWS.Strict          as S-import qualified Control.Monad.Trans.Reader        as L-import qualified Control.Monad.Trans.State.Lazy    as L-import qualified Control.Monad.Trans.State.Strict  as S-import qualified Control.Monad.Trans.Writer.Lazy   as L-import qualified Control.Monad.Trans.Writer.Strict as S-import qualified Data.ByteString.Char8             as B-import qualified Data.ByteString.Lazy.Char8        as BL-import qualified Data.List.NonEmpty                as NE-import qualified Data.Set                          as E-import qualified Data.Text                         as T-import qualified Data.Text.Lazy                    as TL--import Text.Megaparsec.Error-import Text.Megaparsec.Pos--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Word (Word)-#endif--------------------------------------------------------------------------------- Data types---- | This is the Megaparsec's state, it's parametrized over stream type @s@.--data State s = State-  { stateInput :: s-    -- ^ Current input (already processed input is removed from the stream)-  , statePos :: NonEmpty SourcePos-    -- ^ Current position (column + line number) with support for include files-  , stateTokensProcessed :: {-# UNPACK #-} !Word-    -- ^ Number of processed tokens so far-    ---    -- @since 5.2.0-  , stateTabWidth :: Pos-    -- ^ Tab width to use-  } deriving (Show, Eq, Data, Typeable, Generic)--instance NFData s => NFData (State s)--instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State-    <$> arbitrary-    <*> (NE.fromList . getNonEmpty <$> arbitrary)-    <*> choose (1, 10000)-    <*> (unsafePos <$> choose (1, 20))---- | All information available after parsing. This includes consumption of--- input, success (with returned value) or failure (with parse error), and--- parser state at the end of parsing.------ See also: 'Consumption', 'Result'.--data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)---- | This data structure represents an aspect of result of parser's work.------ See also: 'Result', 'Reply'.--data Consumption-  = Consumed -- ^ Some part of input stream was consumed-  | Virgin   -- ^ No input was consumed---- | This data structure represents an aspect of result of parser's work.------ See also: 'Consumption', 'Reply'.--data Result t e a-  = OK a                   -- ^ Parser succeeded-  | Error (ParseError t e) -- ^ Parser failed---- | 'Hints' represent collection of strings to be included into--- 'ParserError' as “expected” message items when a parser fails without--- consuming input right after successful parser that produced the hints.------ For example, without hints you could get:------ >>> parseTest (many (char 'r') <* eof) "ra"--- 1:2:--- unexpected 'a'--- expecting end of input------ We're getting better error messages with help of hints:------ >>> parseTest (many (char 'r') <* eof) "ra"--- 1:2:--- unexpected 'a'--- expecting 'r' or end of input--newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid)---- | Convert 'ParseError' record into 'Hints'.--toHints :: ParseError t e -> Hints t-toHints err = Hints hints-  where hints = if E.null msgs then [] else [msgs]-        msgs  = errorExpected err-{-# INLINE toHints #-}---- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@.------ Note that if resulting continuation gets 'ParseError' that has only--- custom data in it (no “unexpected” or “expected” items), hints are--- ignored.--withHints :: Ord (Token s)-  => Hints (Token s)   -- ^ Hints to use-  -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence-  -> ParseError (Token s) e -- ^ First argument of resulting continuation-  -> State s           -- ^ Second argument of resulting continuation-  -> m b-withHints (Hints ps') c e@(ParseError pos us ps xs) =-  if E.null us && E.null ps && not (E.null xs)-    then c e-    else c (ParseError pos us (E.unions (ps : ps')) xs)-{-# INLINE withHints #-}---- | @accHints hs c@ results in “OK” continuation that will add given hints--- @hs@ to third argument of original continuation @c@.--accHints-  :: Hints t           -- ^ 'Hints' to add-  -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter-  -> a                 -- ^ First argument of resulting continuation-  -> State s           -- ^ Second argument of resulting continuation-  -> Hints t           -- ^ Third argument of resulting continuation-  -> m b-accHints hs1 c x s hs2 = c x s (hs1 <> hs2)-{-# INLINE accHints #-}---- | Replace the most recent group of hints (if any) with the given--- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label'--- primitive.--refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t-refreshLastHint (Hints [])     _        = Hints []-refreshLastHint (Hints (_:xs)) Nothing  = Hints xs-refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs)-{-# INLINE refreshLastHint #-}---- | An instance of @Stream s@ has stream type @s@. Token type is determined--- by the stream and can be found via 'Token' type function.--class Ord (Token s) => Stream s where--  -- | Type of token in stream.-  ---  -- @since 5.0.0--  type Token s :: *--  -- | Get next token from the stream. If the stream is empty, return-  -- 'Nothing'.--  uncons :: s -> Maybe (Token s, s)--  -- | Update position in stream given tab width, current position, and-  -- current token. The result is a tuple where the first element will be-  -- used to report parse errors for current token, while the second element-  -- is the incremented position that will be stored in the parser's state.-  -- The stored (incremented) position is used whenever position can't-  -- be\/shouldn't be updated by consuming a token. For example, when using-  -- 'failure', we don't grab a new token (we need to fail right were we are-  -- now), so error position will be taken from parser's state.-  ---  -- When you work with streams where elements do not contain information-  -- about their position in input, the result is usually consists of the-  -- third argument unchanged and incremented position calculated with-  -- respect to current token. This is how default instances of 'Stream'-  -- work (they use 'defaultUpdatePos', which may be a good starting point-  -- for your own position-advancing function).-  ---  -- When you wish to deal with a stream of tokens where every token “knows”-  -- its start and end position in input (for example, you have produced the-  -- stream with Happy\/Alex), then the best strategy is to use the start-  -- position as the actual element position and provide the end position of-  -- the token as the incremented one.-  ---  -- @since 5.0.0--  updatePos-    :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective)-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> (SourcePos, SourcePos) -- ^ Actual position and incremented position--instance Stream String where-  type Token String = Char-  uncons [] = Nothing-  uncons (t:ts) = Just (t, ts)-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream B.ByteString where-  type Token B.ByteString = Char-  uncons = B.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream BL.ByteString where-  type Token BL.ByteString = Char-  uncons = BL.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream T.Text where-  type Token T.Text = Char-  uncons = T.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}--instance Stream TL.Text where-  type Token TL.Text = Char-  uncons = TL.uncons-  {-# INLINE uncons #-}-  updatePos = const defaultUpdatePos-  {-# INLINE updatePos #-}---- | @Parsec@ is a non-transformer variant of the more general 'ParsecT'--- monad transformer.--type Parsec e s = ParsecT e s Identity---- | @ParsecT e s m a@ is a parser with custom data component of error @e@,--- stream type @s@, underlying monad @m@ and return type @a@.--newtype ParsecT e s m a = ParsecT-  { unParser-      :: forall b. State s-      -> (a -> State s   -> Hints (Token s) -> m b) -- consumed-OK-      -> (ParseError (Token s) e -> State s -> m b) -- consumed-error-      -> (a -> State s   -> Hints (Token s) -> m b) -- empty-OK-      -> (ParseError (Token s) e -> State s -> m b) -- empty-error-      -> m b }--instance (ErrorComponent e, Stream s, Semigroup a)-    => Semigroup (ParsecT e s m a) where-  (<>) = A.liftA2 (<>)-  {-# INLINE (<>) #-}--instance (ErrorComponent e, Stream s, Monoid a)-    => Monoid (ParsecT e s m a) where-  mempty = pure mempty-  {-# INLINE mempty #-}-  mappend = A.liftA2 mappend-  {-# INLINE mappend #-}--instance Functor (ParsecT e s m) where-  fmap = pMap--pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b-pMap f p = ParsecT $ \s cok cerr eok eerr ->-  unParser p s (cok . f) cerr (eok . f) eerr-{-# INLINE pMap #-}--instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where-  pure     = pPure-  (<*>)    = pAp-  p1 *> p2 = p1 `pBind` const p2-  p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }--pAp :: Stream s-  => ParsecT e s m (a -> b)-  -> ParsecT e s m a-  -> ParsecT e s m b-pAp m k = ParsecT $ \s cok cerr eok eerr ->-  let mcok x s' hs = unParser k s' (cok . x) cerr-        (accHints hs (cok . x)) (withHints hs cerr)-      meok x s' hs = unParser k s' (cok . x) cerr-        (accHints hs (eok . x)) (withHints hs eerr)-  in unParser m s mcok cerr meok eerr-{-# INLINE pAp #-}--instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where-  empty  = mzero-  (<|>)  = mplus--instance (ErrorComponent e, Stream s)-    => Monad (ParsecT e s m) where-  return = pure-  (>>=)  = pBind-  fail   = Fail.fail--pPure :: a -> ParsecT e s m a-pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty-{-# INLINE pPure #-}--pBind :: Stream s-  => ParsecT e s m a-  -> (a -> ParsecT e s m b)-  -> ParsecT e s m b-pBind m k = ParsecT $ \s cok cerr eok eerr ->-  let mcok x s' hs = unParser (k x) s' cok cerr-        (accHints hs cok) (withHints hs cerr)-      meok x s' hs = unParser (k x) s' cok cerr-        (accHints hs eok) (withHints hs eerr)-  in unParser m s mcok cerr meok eerr-{-# INLINE pBind #-}--instance (ErrorComponent e, Stream s)-    => Fail.MonadFail (ParsecT e s m) where-  fail = pFail--pFail :: ErrorComponent e => String -> ParsecT e s m a-pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (ParseError pos E.empty E.empty d) s-  where d = E.singleton (representFail msg)-{-# INLINE pFail #-}--mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a-mkPT k = ParsecT $ \s cok cerr eok eerr -> do-  (Reply s' consumption result) <- k s-  case consumption of-    Consumed ->-      case result of-        OK    x -> cok x s' mempty-        Error e -> cerr e s'-    Virgin ->-      case result of-        OK    x -> eok x s' mempty-        Error e -> eerr e s'--instance (ErrorComponent e, Stream s, MonadIO m)-    => MonadIO (ParsecT e s m) where-  liftIO = lift . liftIO--instance (ErrorComponent e, Stream s, MonadReader r m)-    => MonadReader r (ParsecT e s m) where-  ask       = lift ask-  local f p = mkPT $ \s -> local f (runParsecT p s)--instance (ErrorComponent e, Stream s, MonadState st m)-    => MonadState st (ParsecT e s m) where-  get = lift get-  put = lift . put--instance (ErrorComponent e, Stream s, MonadCont m)-    => MonadCont (ParsecT e s m) where-  callCC f = mkPT $ \s ->-    callCC $ \c ->-      runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s-    where pack s a = Reply s Virgin (OK a)--instance (ErrorComponent e, Stream s, MonadError e' m)-    => MonadError e' (ParsecT e s m) where-  throwError = lift . throwError-  p `catchError` h = mkPT $ \s ->-    runParsecT p s `catchError` \e ->-      runParsecT (h e) s--instance (ErrorComponent e, Stream s)-    => MonadPlus (ParsecT e s m) where-  mzero = pZero-  mplus = pPlus--pZero :: ParsecT e s m a-pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (ParseError pos E.empty E.empty E.empty) s-{-# INLINE pZero #-}--pPlus :: (ErrorComponent e, Stream s)-  => ParsecT e s m a-  -> ParsecT e s m a-  -> ParsecT e s m a-pPlus m n = ParsecT $ \s cok cerr eok eerr ->-  let meerr err ms =-        let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')-            neok x s' hs  = eok x s' (toHints err <> hs)-            neerr err' s' = eerr (err' <> err) (longestMatch ms s')-        in unParser n s cok ncerr neok neerr-  in unParser m s cok cerr eok meerr-{-# INLINE pPlus #-}---- | From two states, return the one with the greater number of processed--- tokens. If the numbers of processed tokens are equal, prefer the second--- state.--longestMatch :: State s -> State s -> State s-longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) =-  case tp1 `compare` tp2 of-    LT -> s2-    EQ -> s2-    GT -> s1-{-# INLINE longestMatch #-}--instance MonadTrans (ParsecT e s) where-  lift amb = ParsecT $ \s _ _ eok _ ->-    amb >>= \a -> eok a s mempty--------------------------------------------------------------------------------- Primitive combinators---- | Type class describing parsers independent of input type.--class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m)-    => MonadParsec e s m | m -> e s where--  -- | The most general way to stop parsing and report a 'ParseError'.-  ---  -- 'unexpected' is defined in terms of this function:-  ---  -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty-  ---  -- @since 4.2.0--  failure-    :: Set (ErrorItem (Token s)) -- ^ Unexpected items-    -> Set (ErrorItem (Token s)) -- ^ Expected items-    -> Set e                     -- ^ Custom data-    -> m a--  -- | The parser @label name p@ behaves as parser @p@, but whenever the-  -- parser @p@ fails /without consuming any input/, it replaces names of-  -- “expected” tokens with the name @name@.--  label :: String -> m a -> m a--  -- | @hidden p@ behaves just like parser @p@, but it doesn't show any-  -- “expected” tokens in error message when @p@ fails.--  hidden :: m a -> m a-  hidden = label ""--  -- | The parser @try p@ behaves like parser @p@, except that it backtracks-  -- the parser state when @p@ fails (either consuming input or not).-  ---  -- This combinator is used whenever arbitrary look ahead is needed. Since-  -- it pretends that it hasn't consumed any input when @p@ fails, the-  -- ('A.<|>') combinator will try its second alternative even when the-  -- first parser failed while consuming input.-  ---  -- For example, here is a parser that is supposed to parse the word “let”-  -- or the word “lexical”:-  ---  -- >>> parseTest (string "let" <|> string "lexical") "lexical"-  -- 1:1:-  -- unexpected "lex"-  -- expecting "let"-  ---  -- What happens here? The first parser consumes “le” and fails (because it-  -- doesn't see a “t”). The second parser, however, isn't tried, since the-  -- first parser has already consumed some input! 'try' fixes this behavior-  -- and allows backtracking to work:-  ---  -- >>> parseTest (try (string "let") <|> string "lexical") "lexical"-  -- "lexical"-  ---  -- @try@ also improves error messages in case of overlapping alternatives,-  -- because Megaparsec's hint system can be used:-  ---  -- >>> parseTest (try (string "let") <|> string "lexical") "le"-  -- 1:1:-  -- unexpected "le"-  -- expecting "let" or "lexical"-  ---  -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks-  -- automatically (see 'tokens'), so it does not need 'try'. However, the-  -- examples above demonstrate the idea behind 'try' so well that it was-  -- decided to keep them. You still need to use 'try' when your-  -- alternatives are complex, composite parsers.--  try :: m a -> m a--  -- | If @p@ in @lookAhead p@ succeeds (either consuming input or not) the-  -- whole parser behaves like @p@ succeeded without consuming anything-  -- (parser state is not updated as well). If @p@ fails, @lookAhead@ has no-  -- effect, i.e. it will fail consuming input if @p@ fails consuming input.-  -- Combine with 'try' if this is undesirable.--  lookAhead :: m a -> m a--  -- | @notFollowedBy p@ only succeeds when the parser @p@ fails. This-  -- parser /never consumes/ any input and /never modifies/ parser state. It-  -- can be used to implement the “longest match” rule.--  notFollowedBy :: m a -> m ()--  -- | @withRecovery r p@ allows continue parsing even if parser @p@ fails.-  -- In this case @r@ is called with the actual 'ParseError' as its-  -- argument. Typical usage is to return a value signifying failure to-  -- parse this particular object and to consume some part of the input up-  -- to the point where the next object starts.-  ---  -- Note that if @r@ fails, original error message is reported as if-  -- without 'withRecovery'. In no way recovering parser @r@ can influence-  -- error messages.-  ---  -- @since 4.4.0--  withRecovery-    :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure-    -> m a             -- ^ Original parser-    -> m a             -- ^ Parser that can recover from failures--  -- | @observing p@ allows to “observe” failure of the @p@ parser, should-  -- it happen, without actually ending parsing, but instead getting the-  -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right'-  -- as usual. Note that this primitive just allows you to observe parse-  -- errors as they happen, it does not backtrack or change how the @p@-  -- parser works in any way.-  ---  -- @since 5.1.0--  observing-    :: m a-    -> m (Either (ParseError (Token s) e) a)--  -- | This parser only succeeds at the end of the input.--  eof :: m ()--  -- | The parser @token test mrep@ accepts a token @t@ with result @x@ when-  -- the function @test t@ returns @'Right' x@. @mrep@ may provide-  -- representation of the token to report in error messages when input-  -- stream in empty.-  ---  -- This is the most primitive combinator for accepting tokens. For-  -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:-  ---  -- > satisfy f = token testChar Nothing-  -- >   where-  -- >     testChar x =-  -- >       if f x-  -- >         then Right x-  -- >         else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty)--  token-    :: (Token s -> Either ( Set (ErrorItem (Token s))-                          , Set (ErrorItem (Token s))-                          , Set e ) a)-       -- ^ Matching function for the token to parse, it allows to construct-       -- arbitrary error message on failure as well; sets in three-tuple-       -- are: unexpected items, expected items, and custom data pieces-    -> Maybe (Token s) -- ^ Token to report when input stream is empty-    -> m a--  -- | The parser @tokens test@ parses a list of tokens and returns it.-  -- Supplied predicate @test@ is used to check equality of given and parsed-  -- tokens.-  ---  -- This can be used for example to write 'Text.Megaparsec.Char.string':-  ---  -- > string = tokens (==)-  ---  -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking-  -- primitive, which means that if it fails, it never consumes any input.-  -- This is done to make its consumption model match how error messages for-  -- this primitive are reported (which becomes an important thing as user-  -- gets more control with primitives like 'withRecovery'):-  ---  -- >>> parseTest (string "abc") "abd"-  -- 1:1:-  -- unexpected "abd"-  -- expecting "abc"-  ---  -- This means, in particular, that it's no longer necessary to use 'try'-  -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and-  -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect-  -- performance in any way.--  tokens-    :: (Token s -> Token s -> Bool)-       -- ^ Predicate to check equality of tokens-    -> [Token s]-       -- ^ List of tokens to parse-    -> m [Token s]--  -- | Return the full parser state as a 'State' record.--  getParserState :: m (State s)--  -- | @updateParserState f@ applies the function @f@ to the parser state.--  updateParserState :: (State s -> State s) -> m ()--instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where-  failure           = pFailure-  label             = pLabel-  try               = pTry-  lookAhead         = pLookAhead-  notFollowedBy     = pNotFollowedBy-  withRecovery      = pWithRecovery-  observing         = pObserving-  eof               = pEof-  token             = pToken-  tokens            = pTokens-  getParserState    = pGetParserState-  updateParserState = pUpdateParserState--pFailure-  :: Set (ErrorItem (Token s))-  -> Set (ErrorItem (Token s))-  -> Set e-  -> ParsecT e s m a-pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (ParseError pos us ps xs) s-{-# INLINE pFailure #-}--pLabel :: String -> ParsecT e s m a -> ParsecT e s m a-pLabel l p = ParsecT $ \s cok cerr eok eerr ->-  let el = Label <$> NE.nonEmpty l-      cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l-      cok' x s' hs = cok x s' (refreshLastHint hs cl)-      eok' x s' hs = eok x s' (refreshLastHint hs el)-      eerr'    err = eerr err-        { errorExpected = maybe E.empty E.singleton el }-  in unParser p s cok' cerr eok' eerr'-{-# INLINE pLabel #-}--pTry :: ParsecT e s m a -> ParsecT e s m a-pTry p = ParsecT $ \s cok _ eok eerr ->-  let eerr' err _ = eerr err s-  in unParser p s cok eerr' eok eerr'-{-# INLINE pTry #-}--pLookAhead :: ParsecT e s m a -> ParsecT e s m a-pLookAhead p = ParsecT $ \s _ cerr eok eerr ->-  let eok' a _ _ = eok a s mempty-  in unParser p s eok' cerr eok' eerr-{-# INLINE pLookAhead #-}--pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()-pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr ->-  let what = maybe EndOfInput (Tokens . nes . fst) (uncons input)-      unexpect u = ParseError pos (E.singleton u) E.empty E.empty-      cok' _ _ _ = eerr (unexpect what) s-      cerr'  _ _ = eok () s mempty-      eok' _ _ _ = eerr (unexpect what) s-      eerr'  _ _ = eok () s mempty-  in unParser p s cok' cerr' eok' eerr'-{-# INLINE pNotFollowedBy #-}--pWithRecovery-  :: (ParseError (Token s) e -> ParsecT e s m a)-  -> ParsecT e s m a-  -> ParsecT e s m a-pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->-  let mcerr err ms =-        let rcok x s' _ = cok x s' mempty-            rcerr   _ _ = cerr err ms-            reok x s' _ = eok x s' (toHints err)-            reerr   _ _ = cerr err ms-        in unParser (r err) ms rcok rcerr reok reerr-      meerr err ms =-        let rcok x s' _ = cok x s' (toHints err)-            rcerr   _ _ = eerr err ms-            reok x s' _ = eok x s' (toHints err)-            reerr   _ _ = eerr err ms-        in unParser (r err) ms rcok rcerr reok reerr-  in unParser p s cok mcerr eok meerr-{-# INLINE pWithRecovery #-}--pObserving-  :: ParsecT e s m a-  -> ParsecT e s m (Either (ParseError (Token s) e) a)-pObserving p = ParsecT $ \s cok _ eok _ ->-  let cerr' err s' = cok (Left err) s' mempty-      eerr' err s' = eok (Left err) s' (toHints err)-  in unParser p s (cok . Right) cerr' (eok . Right) eerr'-{-# INLINE pObserving #-}--pEof :: forall e s m. Stream s => ParsecT e s m ()-pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr ->-  case uncons input of-    Nothing    -> eok () s mempty-    Just (x,_) ->-      let !apos = fst (updatePos (Proxy :: Proxy s) w pos x)-      in eerr ParseError-          { errorPos        = apos:|z-          , errorUnexpected = (E.singleton . Tokens . nes) x-          , errorExpected   = E.singleton EndOfInput-          , errorCustom     = E.empty }-          (State input (apos:|z) tp w)-{-# INLINE pEof #-}--pToken :: forall e s m a. Stream s-  => (Token s -> Either ( Set (ErrorItem (Token s))-                        , Set (ErrorItem (Token s))-                        , Set e ) a)-  -> Maybe (Token s)-  -> ParsecT e s m a-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->-  case uncons input of-    Nothing -> eerr ParseError-      { errorPos        = pos:|z-      , errorUnexpected = E.singleton EndOfInput-      , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtoken-      , errorCustom     = E.empty } s-    Just (c,cs) ->-      let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c-      in case test c of-        Left (us, ps, xs) ->-          apos `seq` eerr-            (ParseError (apos:|z) us ps xs)-            (State input (apos:|z) tp w)-        Right x ->-          let newstate = State cs (npos:|z) (tp + 1) w-          in npos `seq` cok x newstate mempty-{-# INLINE pToken #-}--pTokens :: forall e s m. Stream s-  => (Token s -> Token s -> Bool)-  -> [Token s]-  -> ParsecT e s m [Token s]-pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty-pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->-  let updatePos' = updatePos (Proxy :: Proxy s) w-      toTokens   = Tokens . NE.fromList . reverse-      unexpect pos' u = ParseError-        { errorPos        = pos'-        , errorUnexpected = E.singleton u-        , errorExpected   = (E.singleton . Tokens . NE.fromList) tts-        , errorCustom     = E.empty }-      go _ [] is rs =-        let ris   = reverse is-            (npos, tp') = foldl'-              (\(p, n) t -> (snd (updatePos' p t), n + 1))-              (pos, tp)-              ris-        in cok ris (State rs (npos:|z) tp' w) mempty-      go apos (t:ts) is rs =-        case uncons rs of-          Nothing ->-            apos `seq` eerr-              (unexpect (apos:|z) (toTokens is))-              (State input (apos:|z) tp w)-          Just (x,xs) ->-            if test t x-              then go apos ts (x:is) xs-              else apos `seq` eerr-                     (unexpect (apos:|z) . toTokens $ x:is)-                     (State input (apos:|z) tp w)-  in case uncons input of-       Nothing ->-         eerr (unexpect (pos:|z) EndOfInput) s-       Just (x,xs) ->-         let t:ts = tts-             apos = fst (updatePos' pos x)-         in if test t x-              then go apos ts [x] xs-              else apos `seq` eerr-                     (unexpect (apos:|z) $ Tokens (nes x))-                     (State input (apos:|z) tp w)-{-# INLINE pTokens #-}--pGetParserState :: ParsecT e s m (State s)-pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty-{-# INLINE pGetParserState #-}--pUpdateParserState :: (State s -> State s) -> ParsecT e s m ()-pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty-{-# INLINE pUpdateParserState #-}---- | A synonym for 'label' in the form of an operator.--infix 0 <?>--(<?>) :: MonadParsec e s m => m a -> String -> m a-(<?>) = flip label---- | The parser @unexpected item@ fails with an error message telling about--- unexpected item @item@ without consuming any input.--unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a-unexpected item = failure (E.singleton item) E.empty E.empty-{-# INLINE unexpected #-}---- | Return both the result of a parse and the list of tokens that were--- consumed during parsing. This relies on the change of the--- 'stateTokensProcessed' value to evaluate how many tokens were consumed.------ @since 5.3.0--match :: MonadParsec e s m => m a -> m ([Token s], a)-match p = do-  tp  <- getTokensProcessed-  s   <- getInput-  r   <- p-  tp' <- getTokensProcessed-  return (streamTake (tp' - tp) s, r)---- | Specify how to process 'ParseError's that happen inside of this--- wrapper. As a side effect of the current implementation changing--- 'errorPos' with this combinator will also change the final 'statePos' in--- the parser state.------ @since 5.3.0--region :: MonadParsec e s m-  => (ParseError (Token s) e -> ParseError (Token s) e)-     -- ^ How to process 'ParseError's-  -> m a               -- ^ The “region” that processing applies to-  -> m a-region f m = do-  r <- observing m-  case r of-    Left err -> do-      let ParseError {..} = f err-      updateParserState $ \st -> st { statePos = errorPos }-      failure errorUnexpected errorExpected errorCustom-    Right x -> return x---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}--------------------------------------------------------------------------------- Parser state combinators---- | Return the current input.--getInput :: MonadParsec e s m => m s-getInput = stateInput <$> getParserState---- | @setInput input@ continues parsing with @input@. The 'getInput' and--- 'setInput' functions can for example be used to deal with include files.--setInput :: MonadParsec e s m => s -> m ()-setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w)---- | Return the current source position.------ See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--getPosition :: MonadParsec e s m => m SourcePos-getPosition = NE.head . statePos <$> getParserState---- | Get the position where the next token in the stream begins. If the--- stream is empty, return 'Nothing'.------ @since 5.3.0--getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos)-getNextTokenPosition = do-  State {..} <- getParserState-  let f = fst . updatePos (Proxy :: Proxy s) stateTabWidth (NE.head statePos)-  return (f . fst <$> uncons stateInput)---- | @setPosition pos@ sets the current source position to @pos@.------ See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--setPosition :: MonadParsec e s m => SourcePos -> m ()-setPosition pos = updateParserState $ \(State s (_:|z) tp w) ->-  State s (pos:|z) tp w---- | Push a position into stack of positions and continue parsing working--- with this position. Useful for working with include files and the like.------ See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.------ @since 5.0.0--pushPosition :: MonadParsec e s m => SourcePos -> m ()-pushPosition pos = updateParserState $ \(State s z tp w) ->-  State s (NE.cons pos z) tp w---- | Pop a position from the stack of positions unless it only contains one--- element (in that case the stack of positions remains the same). This is--- how to return to previous source file after 'pushPosition'.------ See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.------ @since 5.0.0--popPosition :: MonadParsec e s m => m ()-popPosition = updateParserState $ \(State s z tp w) ->-  case snd (NE.uncons z) of-    Nothing -> State s z  tp w-    Just z' -> State s z' tp w---- | Get the number of tokens processed so far.------ @since 5.2.0--getTokensProcessed :: MonadParsec e s m => m Word-getTokensProcessed = stateTokensProcessed <$> getParserState---- | Set the number of tokens processed so far.------ @since 5.2.0--setTokensProcessed :: MonadParsec e s m => Word -> m ()-setTokensProcessed tp = updateParserState $ \(State s pos _ w) ->-  State s pos tp w---- | Return the tab width. The default tab width is equal to--- 'defaultTabWidth'. You can set a different tab width with the help of--- 'setTabWidth'.--getTabWidth :: MonadParsec e s m => m Pos-getTabWidth = stateTabWidth <$> getParserState---- | Set tab width. If the argument of the function is not a positive--- number, 'defaultTabWidth' will be used.--setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState $ \(State s pos tp _) ->-  State s pos tp w---- | @setParserState st@ sets the parser state to @st@.--setParserState :: MonadParsec e s m => State s -> m ()-setParserState st = updateParserState (const st)--------------------------------------------------------------------------------- Running a parser---- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT'--- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a--- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a--- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn--- 'ParseError' into the string representation of the error message. See--- "Text.Megaparsec.Error" if you need to do more advanced error analysis.------ > main = case (parse numbers "" "11,2,43") of--- >          Left err -> putStr (parseErrorPretty err)--- >          Right xs -> print (sum xs)--- >--- > numbers = integer `sepBy` char ','--parse-  :: Parsec e s a -- ^ Parser to run-  -> String       -- ^ Name of source file-  -> s            -- ^ Input for parser-  -> Either (ParseError (Token s) e) a-parse = runParser---- | @parseMaybe p input@ runs the parser @p@ on @input@ and returns the--- result inside 'Just' on success and 'Nothing' on failure. This function--- also parses 'eof', so if the parser doesn't consume all of its input, it--- will fail.------ The function is supposed to be useful for lightweight parsing, where--- error messages (and thus file name) are not important and entire input--- should be parsed. For example it can be used when parsing of a single--- number according to specification of its format is desired.--parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a-parseMaybe p s =-  case parse (p <* eof) "" s of-    Left  _ -> Nothing-    Right x -> Just x---- | The expression @parseTest p input@ applies the parser @p@ against input--- @input@ and prints the result to stdout. Useful for testing.--parseTest :: ( ShowErrorComponent e-             , Ord (Token s)-             , ShowToken (Token s)-             , Show a )-  => Parsec e s a -- ^ Parser to run-  -> s            -- ^ Input for parser-  -> IO ()-parseTest p input =-  case parse p "" input of-    Left  e -> putStr (parseErrorPretty e)-    Right x -> print x---- | @runParser p file input@ runs parser @p@ on the input stream of tokens--- @input@, obtained from source @file@. The @file@ is only used in error--- messages and may be the empty string. Returns either a 'ParseError'--- ('Left') or a value of type @a@ ('Right').------ > parseFromFile p file = runParser p file <$> readFile file--runParser-  :: Parsec e s a -- ^ Parser to run-  -> String     -- ^ Name of source file-  -> s          -- ^ Input for parser-  -> Either (ParseError (Token s) e) a-runParser p name s = snd $ runParser' p (initialState name s)---- | The function is similar to 'runParser' with the difference that it--- accepts and returns parser state. This allows to specify arbitrary--- textual position at the beginning of parsing, for example. This is the--- most general way to run a parser over the 'Identity' monad.------ @since 4.2.0--runParser'-  :: Parsec e s a -- ^ Parser to run-  -> State s    -- ^ Initial state-  -> (State s, Either (ParseError (Token s) e) a)-runParser' p = runIdentity . runParserT' p---- | @runParserT p file input@ runs parser @p@ on the input list of tokens--- @input@, obtained from source @file@. The @file@ is only used in error--- messages and may be the empty string. Returns a computation in the--- underlying monad @m@ that returns either a 'ParseError' ('Left') or a--- value of type @a@ ('Right').--runParserT :: Monad m-  => ParsecT e s m a -- ^ Parser to run-  -> String        -- ^ Name of source file-  -> s             -- ^ Input for parser-  -> m (Either (ParseError (Token s) e) a)-runParserT p name s = snd `liftM` runParserT' p (initialState name s)---- | This function is similar to 'runParserT', but like 'runParser'' it--- accepts and returns parser state. This is thus the most general way to--- run a parser.------ @since 4.2.0--runParserT' :: Monad m-  => ParsecT e s m a -- ^ Parser to run-  -> State s       -- ^ Initial state-  -> m (State s, Either (ParseError (Token s) e) a)-runParserT' p s = do-  (Reply s' _ result) <- runParsecT p s-  case result of-    OK    x -> return (s', Right x)-    Error e -> return (s', Left  e)---- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser'--- are built upon this.--runParsecT :: Monad m-  => ParsecT e s m a -- ^ Parser to run-  -> State s       -- ^ Initial state-  -> m (Reply e s a)-runParsecT p s = unParser p s cok cerr eok eerr-  where cok a s' _  = return $ Reply s' Consumed (OK a)-        cerr err s' = return $ Reply s' Consumed (Error err)-        eok a s' _  = return $ Reply s' Virgin   (OK a)-        eerr err s' = return $ Reply s' Virgin   (Error err)---- | Given name of source file and input construct initial state for parser.--initialState :: String -> s -> State s-initialState name s = State-  { stateInput           = s-  , statePos             = initialPos name :| []-  , stateTokensProcessed = 0-  , stateTabWidth        = defaultTabWidth }--------------------------------------------------------------------------------- Instances of 'MonadParsec'--instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where-  failure us ps xs           = lift (failure us ps xs)-  label n       (L.StateT m) = L.StateT $ label n . m-  try           (L.StateT m) = L.StateT $ try . m-  lookAhead     (L.StateT m) = L.StateT $ \s ->-    (,s) . fst <$> lookAhead (m s)-  notFollowedBy (L.StateT m) = L.StateT $ \s ->-    notFollowedBy (fst <$> m s) >> return ((),s)-  withRecovery r (L.StateT m) = L.StateT $ \s ->-    withRecovery (\e -> L.runStateT (r e) s) (m s)-  observing     (L.StateT m) = L.StateT $ \s ->-    fixs s <$> observing (m s)-  eof                        = lift eof-  token test mt              = lift (token test mt)-  tokens e ts                = lift (tokens e ts)-  getParserState             = lift getParserState-  updateParserState f        = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where-  failure us ps xs           = lift (failure us ps xs)-  label n       (S.StateT m) = S.StateT $ label n . m-  try           (S.StateT m) = S.StateT $ try . m-  lookAhead     (S.StateT m) = S.StateT $ \s ->-    (,s) . fst <$> lookAhead (m s)-  notFollowedBy (S.StateT m) = S.StateT $ \s ->-    notFollowedBy (fst <$> m s) >> return ((),s)-  withRecovery r (S.StateT m) = S.StateT $ \s ->-    withRecovery (\e -> S.runStateT (r e) s) (m s)-  observing     (S.StateT m) = S.StateT $ \s ->-    fixs s <$> observing (m s)-  eof                        = lift eof-  token test mt              = lift (token test mt)-  tokens e ts                = lift (tokens e ts)-  getParserState             = lift getParserState-  updateParserState f        = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where-  failure us ps xs            = lift (failure us ps xs)-  label n       (L.ReaderT m) = L.ReaderT $ label n . m-  try           (L.ReaderT m) = L.ReaderT $ try . m-  lookAhead     (L.ReaderT m) = L.ReaderT $ lookAhead . m-  notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m-  withRecovery r (L.ReaderT m) = L.ReaderT $ \s ->-    withRecovery (\e -> L.runReaderT (r e) s) (m s)-  observing     (L.ReaderT m) = L.ReaderT $ observing . m-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift (tokens e ts)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where-  failure us ps xs            = lift (failure us ps xs)-  label n       (L.WriterT m) = L.WriterT $ label n m-  try           (L.WriterT m) = L.WriterT $ try m-  lookAhead     (L.WriterT m) = L.WriterT $-    (,mempty) . fst <$> lookAhead m-  notFollowedBy (L.WriterT m) = L.WriterT $-    (,mempty) <$> notFollowedBy (fst <$> m)-  withRecovery r (L.WriterT m) = L.WriterT $-    withRecovery (L.runWriterT . r) m-  observing     (L.WriterT m) = L.WriterT $-    fixs mempty <$> observing m-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift (tokens e ts)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where-  failure us ps xs            = lift (failure us ps xs)-  label n       (S.WriterT m) = S.WriterT $ label n m-  try           (S.WriterT m) = S.WriterT $ try m-  lookAhead     (S.WriterT m) = S.WriterT $-    (,mempty) . fst <$> lookAhead m-  notFollowedBy (S.WriterT m) = S.WriterT $-    (,mempty) <$> notFollowedBy (fst <$> m)-  withRecovery r (S.WriterT m) = S.WriterT $-    withRecovery (S.runWriterT . r) m-  observing     (S.WriterT m) = S.WriterT $-    fixs mempty <$> observing m-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift (tokens e ts)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where-  failure us ps xs            = lift (failure us ps xs)-  label n          (L.RWST m) = L.RWST $ \r s -> label n (m r s)-  try              (L.RWST m) = L.RWST $ \r s -> try (m r s)-  lookAhead        (L.RWST m) = L.RWST $ \r s -> do-    (x,_,_) <- lookAhead (m r s)-    return (x,s,mempty)-  notFollowedBy    (L.RWST m) = L.RWST $ \r s -> do-    notFollowedBy (void $ m r s)-    return ((),s,mempty)-  withRecovery   n (L.RWST m) = L.RWST $ \r s ->-    withRecovery (\e -> L.runRWST (n e) r s) (m r s)-  observing        (L.RWST m) = L.RWST $ \r s ->-    fixs' s <$> observing (m r s)-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift (tokens e ts)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where-  failure us ps xs            = lift (failure us ps xs)-  label n          (S.RWST m) = S.RWST $ \r s -> label n (m r s)-  try              (S.RWST m) = S.RWST $ \r s -> try (m r s)-  lookAhead        (S.RWST m) = S.RWST $ \r s -> do-    (x,_,_) <- lookAhead (m r s)-    return (x,s,mempty)-  notFollowedBy    (S.RWST m) = S.RWST $ \r s -> do-    notFollowedBy (void $ m r s)-    return ((),s,mempty)-  withRecovery   n (S.RWST m) = S.RWST $ \r s ->-    withRecovery (\e -> S.runRWST (n e) r s) (m r s)-  observing        (S.RWST m) = S.RWST $ \r s ->-    fixs' s <$> observing (m r s)-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift (tokens e ts)-  getParserState              = lift getParserState-  updateParserState f         = lift (updateParserState f)--instance MonadParsec e s m => MonadParsec e s (IdentityT m) where-  failure us ps xs            = lift (failure us ps xs)-  label n       (IdentityT m) = IdentityT $ label n m-  try                         = IdentityT . try . runIdentityT-  lookAhead     (IdentityT m) = IdentityT $ lookAhead m-  notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m-  withRecovery r (IdentityT m) = IdentityT $-    withRecovery (runIdentityT . r) m-  observing     (IdentityT m) = IdentityT $ observing m-  eof                         = lift eof-  token test mt               = lift (token test mt)-  tokens e ts                 = lift $ tokens e ts-  getParserState              = lift getParserState-  updateParserState f         = lift $ updateParserState f--fixs :: s -> Either a (b, s) -> (Either a b, s)-fixs s (Left a)       = (Left a, s)-fixs _ (Right (b, s)) = (Right b, s)-{-# INLINE fixs #-}--fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w)-fixs' s (Left a)        = (Left a, s, mempty)-fixs' _ (Right (b,s,w)) = (Right b, s, w)-{-# INLINE fixs' #-}--------------------------------------------------------------------------------- Debugging---- | @dbg label p@ parser works exactly like @p@, but when it's evaluated it--- also prints information useful for debugging. The @label@ is only used to--- refer to this parser in the debugging output. This combinator uses the--- 'trace' function from "Debug.Trace" under the hood.------ Typical usage is to wrap every sub-parser in misbehaving parser with--- 'dbg' assigning meaningful labels. Then give it a shot and go through the--- print-out. As of current version, this combinator prints all available--- information except for /hints/, which are probably only interesting to--- the maintainer of Megaparsec itself and may be quite verbose to output in--- general. Let me know if you would like to be able to see hints in the--- debugging output.------ The output itself is pretty self-explanatory, although the following--- abbreviations should be clarified (they are derived from the low-level--- source code):------     * @COK@—“consumed OK”. The parser consumed input and succeeded.---     * @CERR@—“consumed error”. The parser consumed input and failed.---     * @EOK@—“empty OK”. The parser succeeded without consuming input.---     * @EERR@—“empty error”. The parser failed without consuming input.------ Finally, it's not possible to lift this function into some monad--- transformers without introducing surprising behavior (e.g. unexpected--- state backtracking) or adding otherwise redundant constraints (e.g.--- 'Show' instance for state), so this helper is only available for--- 'ParsecT' monad, not 'MonadParsec' in general.------ @since 5.1.0--dbg :: forall e s m a.-  ( Stream s-  , ShowToken (Token s)-  , ShowErrorComponent e-  , Show a )-  => String            -- ^ Debugging label-  -> ParsecT e s m a   -- ^ Parser to debug-  -> ParsecT e s m a   -- ^ Parser that prints debugging messages-dbg lbl p = ParsecT $ \s cok cerr eok eerr ->-  let l = dbgLog lbl :: DbgItem s e a -> String-      cok' x s' hs = flip trace (cok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)-      cerr' err s' = flip trace (cerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)-      eok' x s' hs = flip trace (eok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)-      eerr' err s' = flip trace (eerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)-  in unParser p s cok' cerr' eok' eerr'---- | A single piece of info to be rendered with 'dbgLog'.--data DbgItem s e a-  = DbgIn   [Token s]-  | DbgCOK  [Token s] a-  | DbgCERR [Token s] (ParseError (Token s) e)-  | DbgEOK  [Token s] a-  | DbgEERR [Token s] (ParseError (Token s) e)---- | Render a single piece of debugging info.--dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s))-  => String            -- ^ Debugging label-  -> DbgItem s e a     -- ^ Information to render-  -> String            -- ^ Rendered result-dbgLog lbl item = prefix msg-  where-    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines-    msg = case item of-      DbgIn   ts   ->-        "IN: " ++ showStream ts-      DbgCOK  ts a ->-        "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgCERR ts e ->-        "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e-      DbgEOK  ts a ->-        "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgEERR ts e ->-        "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e---- | Pretty-print a list of tokens.--showStream :: ShowToken t => [t] -> String-showStream ts =-  case NE.nonEmpty ts of-    Nothing -> "<EMPTY>"-    Just ne ->-      let (h, r) = splitAt 40 (showTokens ne)-      in if null r then h else h ++ " <…>"---- | Calculate number of consumed tokens given 'State' of parser before and--- after parsing.--streamDelta-  :: State s           -- ^ State of parser before consumption-  -> State s           -- ^ State of parser after consumption-  -> Word              -- ^ Number of consumed tokens-streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0---- | Extract a given number of tokens from the stream.--streamTake :: Stream s => Word -> s -> [Token s]-streamTake n s = genericTake n (unfold s)---- | A custom version of 'unfold' that matches signature of the 'uncons'--- method in the 'Stream' type class we use.--unfold :: Stream s => s -> [Token s]-unfold s = case uncons s of-  Nothing -> []-  Just (t, s') -> t : unfold s'
+ Text/Megaparsec/Stream.hs view
@@ -0,0 +1,286 @@+-- |+-- Module      :  Text.Megaparsec.Stream+-- Copyright   :  © 2015–2017 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Megaparsec's input stream facilities.+--+-- You probably do not want to import this module directly because+-- "Text.Megaparsec" re-exports it anyway.+--+-- @since 6.0.0++{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies      #-}++module Text.Megaparsec.Stream+  ( Stream (..) )+where++import Data.List (foldl')+import Data.Proxy+import Data.Semigroup ((<>))+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++-- | Type class for inputs that can be consumed by the library.++class (Ord (Token s), Ord (Tokens s)) => Stream s where++  -- | Type of token in the stream.++  type Token s :: *++  -- | Type of “chunk” of the stream.++  type Tokens s :: *++  -- | Lift a single token to chunk of the stream. The default+  -- implementation is:+  --+  -- > tokenToChunk pxy = tokensToChunk pxy . pure+  --+  -- However for some types of stream there may be a more efficient way to+  -- lift.++  tokenToChunk  :: Proxy s -> Token s -> Tokens s+  tokenToChunk pxy = tokensToChunk pxy . pure++  -- | The first method that establishes isomorphism between list of tokens+  -- and chunk of the stream. Valid implementation should satisfy:+  --+  -- > chunkToTokens pxy (tokensToChunk pxy ts) == ts++  tokensToChunk :: Proxy s -> [Token s] -> Tokens s++  -- | The second method that establishes isomorphism between list of tokens+  -- and chunk of the stream. Valid implementation should satisfy:+  --+  -- > tokensToChunk pxy (chunkToTokens pxy chunk) == chunk++  chunkToTokens :: Proxy s -> Tokens s -> [Token s]++  -- | Return length of a chunk of the stream.++  chunkLength :: Proxy s -> Tokens s -> Int++  -- | Check if a chunk of the stream is empty. The default implementation+  -- is in terms of the more general 'chunkLength':+  --+  -- > chunkEmpty pxy ts = chunkLength pxy ts <= 0+  --+  -- However for many streams there may be a more efficient implementation.++  chunkEmpty :: Proxy s -> Tokens s -> Bool+  chunkEmpty pxy ts = chunkLength pxy ts <= 0+  {-# 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+  -- stream is too short, the rest of the stream. Valid implementation+  -- should follow the rules:+  --+  --     * If the requested length @n@ is 0 (or less), 'Nothing' should+  --       never be returned, instead @'Just' (\"\", s)@ should be returned,+  --       where @\"\"@ stands for the empty chunk, and @s@ is the original+  --       stream (second argument).+  --     * If the requested length is greater than 0 and the stream is+  --       empty, 'Nothing' should be returned indicating end of input.+  --     * In other cases, take chunk of length @n@ (or shorter if the+  --       stream is not long enough) from the input stream and return the+  --       chunk along with the rest of the stream.++  takeN_ :: Int -> s -> Maybe (Tokens s, s)++  -- | Extract chunk of the stream taking tokens while the supplied+  -- predicate returns 'True'. Return the chunk and the rest of the stream.+  --+  -- For many types of streams, the method allows for significant+  -- performance improvements, although it is not strictly necessary from+  -- conceptual point of view.++  takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s)++instance Stream String where+  type Token String = Char+  type Tokens String = String+  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)+  takeN_ n s+    | 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+  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++instance Stream BL.ByteString where+  type Token BL.ByteString = Word8+  type Tokens 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)+    | BL.null s = Nothing+    | otherwise = Just (BL.splitAt (fromIntegral n) s)+  takeWhile_ = BL.span++instance Stream T.Text where+  type Token T.Text = Char+  type Tokens 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++instance Stream TL.Text where+  type Token TL.Text  = Char+  type Tokens 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)+    | TL.null s = Nothing+    | otherwise = Just (TL.splitAt (fromIntegral n) s)+  takeWhile_ = TL.span++----------------------------------------------------------------------------+-- 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.++defaultPositionAt :: SourcePos -> a -> SourcePos+defaultPositionAt pos _ = pos+{-# INLINE defaultPositionAt #-}++-- | 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.++defaultAdvance1 :: Enum t+  => Pos               -- ^ Tab width+  -> SourcePos         -- ^ Current position+  -> t                 -- ^ Current token+  -> SourcePos         -- ^ Incremented position+defaultAdvance1 width (SourcePos n l c) t = npos+  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 #-}
− Text/Megaparsec/String.hs 
@@ -1,21 +0,0 @@--- |--- Module      :  Text.Megaparsec.String--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with 'String' as input stream.--module Text.Megaparsec.String (Parser) where--import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for 'String's.--type Parser = Parsec Dec String
− Text/Megaparsec/Text.hs 
@@ -1,22 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with strict 'Text'.--module Text.Megaparsec.Text (Parser) where--import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim-import Data.Text---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of input stream--- by importing different “type modules”. This one is for strict 'Text'.--type Parser = Parsec Dec Text
− Text/Megaparsec/Text/Lazy.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Text.Megaparsec.Text.Lazy--- Copyright   :  © 2015–2017 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Convenience definitions for working with lazy 'Text'.--module Text.Megaparsec.Text.Lazy (Parser) where--import Data.Text.Lazy-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Prim---- | Modules corresponding to various types of streams define 'Parser'--- accordingly, so the user can use it to easily change type of the input--- stream by importing different “type modules”. This one is for lazy--- 'Text'.--type Parser = Parsec Dec Text
− bench-memory/Main.hs 
@@ -1,66 +0,0 @@-module Main (main) where--import Control.DeepSeq-import Control.Monad-import Text.Megaparsec-import Text.Megaparsec.String-import Weigh--main :: IO ()-main = mainWith $ do-  setColumns [Case, Allocated, GCs, Max]-  bparser "string"   manyAs (string . fst)-  bparser "string'"  manyAs (string' . fst)-  bparser "choice"   (const "b") (choice . fmap char . manyAsB . snd)-  bparser "many"     manyAs (const $ many (char 'a'))-  bparser "some"     manyAs (const $ some (char 'a'))-  bparser "count"    manyAs (\(_,n) -> count n (char 'a'))-  bparser "count'"   manyAs (\(_,n) -> count' 1 n (char 'a'))-  bparser "endBy"    manyAbs' (const $ endBy (char 'a') (char 'b'))-  bparser "endBy1"   manyAbs' (const $ endBy1 (char 'a') (char 'b'))-  bparser "sepBy"    manyAbs (const $ sepBy (char 'a') (char 'b'))-  bparser "sepBy1"   manyAbs (const $ sepBy1 (char 'a') (char 'b'))-  bparser "sepEndBy"  manyAbs' (const $ sepEndBy (char 'a') (char 'b'))-  bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))-  bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))-  bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))---- | Perform a series of measurements with the same parser.--bparser :: NFData a-  => String            -- ^ Name of the benchmark group-  -> (Int -> String)   -- ^ How to construct input-  -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input-  -> Weigh ()-bparser name f p = forM_ stdSeries $ \i -> do-  let arg      = (f i,i)-      p' (s,n) = parse (p (s,n)) "" s-  func (name ++ "/" ++ show i) p' arg---- | The series of sizes to try as part of 'bparser'.--stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]--------------------------------------------------------------------------------- Helpers---- | Generate that many \'a\' characters.--manyAs :: Int -> String-manyAs n = replicate n 'a'---- | Like 'manyAs', but interspersed with \'b\'s.--manyAbs :: Int -> String-manyAbs n = take (if even n then n + 1 else n) (cycle "ab")---- | Like 'manyAs', but with a \'b\' added to the end.--manyAsB :: Int -> String-manyAsB n = replicate n 'a' ++ "b"---- | Like 'manyAbs', but ends in a \'b\'.--manyAbs' :: Int -> String-manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
− bench-speed/Main.hs 
@@ -1,65 +0,0 @@-module Main (main) where--import Control.DeepSeq-import Criterion.Main-import Text.Megaparsec-import Text.Megaparsec.String--main :: IO ()-main = defaultMain-  [ bparser "string"   manyAs (string . fst)-  , bparser "string'"  manyAs (string' . fst)-  , bparser "choice"   (const "b") (choice . fmap char . manyAsB . snd)-  , bparser "many"     manyAs (const $ many (char 'a'))-  , bparser "some"     manyAs (const $ some (char 'a'))-  , bparser "count"    manyAs (\(_,n) -> count n (char 'a'))-  , bparser "count'"   manyAs (\(_,n) -> count' 1 n (char 'a'))-  , bparser "endBy"    manyAbs' (const $ endBy (char 'a') (char 'b'))-  , bparser "endBy1"   manyAbs' (const $ endBy1 (char 'a') (char 'b'))-  , bparser "sepBy"    manyAbs (const $ sepBy (char 'a') (char 'b'))-  , bparser "sepBy1"   manyAbs (const $ sepBy1 (char 'a') (char 'b'))-  , bparser "sepEndBy"  manyAbs' (const $ sepEndBy (char 'a') (char 'b'))-  , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))-  , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))-  , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))-  ]---- | Perform a series to measurements with the same parser.--bparser :: NFData a-  => String            -- ^ Name of the benchmark group-  -> (Int -> String)   -- ^ How to construct input-  -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input-  -> Benchmark         -- ^ The benchmark-bparser name f p = bgroup name (bs <$> stdSeries)-  where-    bs n = env (return (f n, n)) (bench (show n) . nf p')-    p' (s,n) = parse (p (s,n)) "" s---- | The series of sizes to try as part of 'bparser'.--stdSeries :: [Int]-stdSeries = [500,1000,2000,4000]--------------------------------------------------------------------------------- Helpers---- | Generate that many \'a\' characters.--manyAs :: Int -> String-manyAs n = replicate n 'a'---- | Like 'manyAs', but with a \'b\' added to the end.--manyAsB :: Int -> String-manyAsB n = replicate n 'a' ++ "b"---- | Like 'manyAs', but interspersed with \'b\'s and ends in a \'a\'.--manyAbs :: Int -> String-manyAbs n = take (if even n then n + 1 else n) (cycle "ab")---- | Like 'manyAbs', but ends in a \'b\'.--manyAbs' :: Int -> String-manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
+ bench/memory/Main.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.DeepSeq+import Control.Monad+import Data.Semigroup ((<>))+import Data.Text (Text)+import Data.Void+import Text.Megaparsec+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.++type Parser = Parsec Void Text++main :: IO ()+main = mainWith $ do+  setColumns [Case, Allocated, GCs, Max]+  bparser "string"   manyAs (string . fst)+  bparser "string'"  manyAs (string' . fst)+  bparser "many"     manyAs (const $ many (char 'a'))+  bparser "some"     manyAs (const $ some (char 'a'))+  bparser "choice"   (const "b") (choice . fmap char . manyAsB' . snd)+  bparser "count"    manyAs (\(_,n) -> count n (char 'a'))+  bparser "count'"   manyAs (\(_,n) -> count' 1 n (char 'a'))+  bparser "endBy"    manyAbs' (const $ endBy (char 'a') (char 'b'))+  bparser "endBy1"   manyAbs' (const $ endBy1 (char 'a') (char 'b'))+  bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))+  bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))+  bparser "sepBy"    manyAbs (const $ sepBy (char 'a') (char 'b'))+  bparser "sepBy1"   manyAbs (const $ sepBy1 (char 'a') (char 'b'))+  bparser "sepEndBy"  manyAbs' (const $ sepEndBy (char 'a') (char 'b'))+  bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))+  bparser "skipMany" manyAs (const $ skipMany (char 'a'))+  bparser "skipSome" manyAs (const $ skipSome (char 'a'))+  bparser "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)++-- | Perform a series of 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+  -> Weigh ()+bparser name f p = forM_ stdSeries $ \i -> do+  let arg      = (f i,i)+      p' (s,n) = parse (p (s,n)) "" s+  func (name ++ "/" ++ show i) p' arg++-- | The series of sizes to try as part of 'bparser'.++stdSeries :: [Int]+stdSeries = [500,1000,2000,4000]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.++manyAs :: Int -> Text+manyAs n = T.replicate n "a"++-- | Like 'manyAs', but interspersed with \'b\'s.++manyAbs :: Int -> Text+manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab")++-- | Like 'manyAs', but with a \'b\' added to the end.++manyAsB :: Int -> Text+manyAsB n = manyAs n <> "b"++-- | Like 'manyAsB', but returns a 'String'.++manyAsB' :: Int -> String+manyAsB' n = replicate n 'a' ++ "b"++-- | Like 'manyAbs', but ends in a \'b\'.++manyAbs' :: Int -> Text+manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab")++-- | Render an 'Integer' with the number of digits linearly dependent on the+-- argument.++mkInt :: Int -> Text+mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100))
+ bench/speed/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.DeepSeq+import Criterion.Main+import Data.Semigroup ((<>))+import Data.Text (Text)+import Data.Void+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Data.Text                  as T+import qualified Text.Megaparsec.Char.Lexer as L++-- | The type of parser that consumes 'String's.++type Parser = Parsec Void Text++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 "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)+  ]++-- | 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 name f p = bgroup name (bs <$> stdSeries)+  where+    bs n = env (return (f n, n)) (bench (show n) . nf p')+    p' (s,n) = parse (p (s,n)) "" s++-- | The series of sizes to try as part of 'bparser'.++stdSeries :: [Int]+stdSeries = [500,1000,2000,4000]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.++manyAs :: Int -> Text+manyAs n = T.replicate n "a"++-- | Like 'manyAs', but interspersed with \'b\'s.++manyAbs :: Int -> Text+manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab")++-- | Like 'manyAs', but with a \'b\' added to the end.++manyAsB :: Int -> Text+manyAsB n = manyAs n <> "b"++-- | Like 'manyAsB', but returns a 'String'.++manyAsB' :: Int -> String+manyAsB' n = replicate n 'a' ++ "b"++-- | Like 'manyAbs', but ends in a \'b\'.++manyAbs' :: Int -> Text+manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab")++-- | Render an 'Integer' with the number of digits linearly dependent on the+-- argument.++mkInt :: Int -> Text+mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100))
megaparsec.cabal view
@@ -1,6 +1,6 @@ name:                 megaparsec-version:              5.3.1-cabal-version:        >= 1.10+version:              6.0.0+cabal-version:        >= 1.18 tested-with:          GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license:              BSD2 license-file:         LICENSE.md@@ -33,39 +33,32 @@   default:            False  library-  build-depends:      QuickCheck   >= 2.7   && < 2.11-                    , base         >= 4.7   && < 5.0+  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-                    , exceptions   >= 0.6   && < 0.9                     , mtl          >= 2.0   && < 3.0+                    , parser-combinators >= 0.1 && < 0.2                     , scientific   >= 0.3.1 && < 0.4                     , text         >= 0.2   && < 1.3                     , transformers >= 0.4   && < 0.6-   if !impl(ghc >= 8.0)-    -- packages providing modules that moved into base-4.9.0.0     build-depends:    fail         == 4.9.*                     , semigroups   == 0.18.*--  if !impl(ghc >= 7.8)-    build-depends:    tagged       == 0.8.*-+  if !impl(ghc >= 7.10)+    build-depends:    void         == 0.7.*   exposed-modules:    Text.Megaparsec-                    , Text.Megaparsec.ByteString-                    , Text.Megaparsec.ByteString.Lazy+                    , Text.Megaparsec.Byte+                    , Text.Megaparsec.Byte.Lexer                     , Text.Megaparsec.Char-                    , Text.Megaparsec.Combinator+                    , Text.Megaparsec.Char.Lexer                     , Text.Megaparsec.Error+                    , Text.Megaparsec.Error.Builder                     , Text.Megaparsec.Expr-                    , Text.Megaparsec.Lexer                     , Text.Megaparsec.Perm                     , Text.Megaparsec.Pos-                    , Text.Megaparsec.Prim-                    , Text.Megaparsec.String-                    , Text.Megaparsec.Text-                    , Text.Megaparsec.Text.Lazy+                    , Text.Megaparsec.Stream   if flag(dev)     ghc-options:      -Wall -Werror   else@@ -80,21 +73,23 @@     ghc-options:      -Wall -Werror   else     ghc-options:      -O2 -Wall-  other-modules:      Test.Hspec.Megaparsec+  other-modules:      Control.Applicative.CombinatorsSpec+                    , Test.Hspec.Megaparsec                     , Test.Hspec.Megaparsec.AdHoc+                    , Text.Megaparsec.Byte.LexerSpec+                    , Text.Megaparsec.ByteSpec+                    , Text.Megaparsec.Char.LexerSpec                     , Text.Megaparsec.CharSpec-                    , Text.Megaparsec.CombinatorSpec                     , Text.Megaparsec.ErrorSpec                     , Text.Megaparsec.ExprSpec-                    , Text.Megaparsec.LexerSpec                     , Text.Megaparsec.PermSpec                     , Text.Megaparsec.PosSpec-                    , Text.Megaparsec.PrimSpec+                    , Text.Megaparsec.StreamSpec+                    , Text.MegaparsecSpec   build-depends:      QuickCheck   >= 2.7   && < 2.11                     , base         >= 4.7   && < 5.0                     , bytestring   >= 0.2   && < 0.11                     , containers   >= 0.5   && < 0.6-                    , exceptions   >= 0.6   && < 0.9                     , hspec        >= 2.0   && < 3.0                     , hspec-expectations >= 0.5 && < 0.9                     , megaparsec@@ -102,24 +97,25 @@                     , scientific   >= 0.3.1 && < 0.4                     , text         >= 0.2   && < 1.3                     , transformers >= 0.4   && < 0.6-   if !impl(ghc >= 8.0)-    -- packages providing modules that moved into base-4.9.0.0-    build-depends:    semigroups     == 0.18.*--  if !impl(ghc >= 7.8)-    build-depends:    tagged       == 0.8.*-+    build-depends:    semigroups   == 0.18.*+  if !impl(ghc >= 7.10)+    build-depends:    void         == 0.7.*   default-language:   Haskell2010  benchmark bench-speed   main-is:            Main.hs-  hs-source-dirs:     bench-speed+  hs-source-dirs:     bench/speed   type:               exitcode-stdio-1.0   build-depends:      base         >= 4.7  && < 5.0                     , criterion    >= 0.6.2.1 && < 1.3                     , deepseq      >= 1.3  && < 1.5                     , megaparsec+                    , 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@@ -128,12 +124,17 @@  benchmark bench-memory   main-is:            Main.hs-  hs-source-dirs:     bench-memory+  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
+ tests/Control/Applicative/CombinatorsSpec.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE MultiWayIf #-}++module Control.Applicative.CombinatorsSpec (spec) where++import Control.Applicative+import Data.Char (isLetter, isDigit)+import Data.List (intersperse)+import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)+import Data.Monoid+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Char++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" . it "works" . property $ \n x' -> do+    let x = getNonNegative x'+        p = count n (char 'x')+        p' = count' n n (char 'x')+        s = replicate x 'x'+    prs_ p s `shouldBe` prs_ p' s++  describe "count'" . it "works" . property $ \m n x' -> do+    let x = getNonNegative x'+        p = count' m n (char 'x')+        s = replicate x 'x'+    if | n <= 0 || m > n ->+         if x == 0+           then prs_ p s `shouldParse` ""+           else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)+       | m <= x && x <= n ->+         prs_ p s `shouldParse` s+       | x < m ->+         prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)++  describe "eitherP" . it "works" . property $ \ch -> do+    let p = eitherP letterChar digitChar+        s = pure ch+    if | isLetter ch -> prs_ p s `shouldParse` Left ch+       | isDigit  ch -> prs_ p s `shouldParse` Right ch+       | otherwise   -> prs_ p s `shouldFailWith`+         err posI (utok ch <> elabel "letter" <> elabel "digit")++  describe "endBy" . it "works" . property $ \n' c -> do+    let n = getNonNegative n'+        p = endBy (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ [c]+    if | c == 'a' && n == 0 ->+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+       | c == 'a' ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+       | c == '-' && n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)+       | c /= '-' ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           ( utok c <>+             (if n > 0 then etok '-' else eeof) <>+             (if n == 0 then etok 'a' else mempty) )+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'++  describe "endBy1" . it "works" . property $ \n' c -> do+    let n = getNonNegative n'+        p = endBy1 (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ [c]+    if | c == 'a' && n == 0 ->+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+       | c == 'a' ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+       | c == '-' && n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')+       | c /= '-' ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           ( utok c <>+             (if n > 0 then etok '-' else mempty) <>+             (if n == 0 then etok 'a' else mempty) )+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'++  describe "manyTill" . it "works" . property $ \a' b' c' -> do+    let [a,b,c] = getNonNegative <$> [a',b',c']+        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar+        s = abcRow a b c+    if c == 0+      then prs_ p s `shouldFailWith` err (posN (a + b) s)+           (ueof <> etok 'c' <> elabel "letter")+      else let (pre, post) = break (== 'c') s+           in prs_ p s `shouldParse` (pre, drop 1 post)++  describe "someTill" . it "works" . property $ \a' b' c' -> do+    let [a,b,c] = getNonNegative <$> [a',b',c']+        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar+        s = abcRow a b c+    if | null s ->+         prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")+       | c == 0 ->+         prs_ p s `shouldFailWith` err (posN (a + b) s)+           (ueof <> etok 'c' <> elabel "letter")+       | s == "c" ->+         prs_ p s `shouldFailWith` err+           (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")+       | head s == 'c' ->+         prs_ p s `shouldParse` ("c", drop 2 s)+       | otherwise ->+         let (pre, post) = break (== 'c') s+         in prs_ p s `shouldParse` (pre, drop 1 post)++  describe "option" . it "works" . property $ \d a s -> do+    let p = option d (string a)+        p' = fromMaybe d <$> optional (string a)+    prs_ p s `shouldBe` prs_ p' s++  describe "sepBy" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepBy (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' ->+         prs_ p s `shouldParse` replicate n 'a'+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI+           (utok c <> etok 'a' <> eeof)+       | c == '-' ->+         prs_ p s `shouldFailWith` err (posN (length s) s)+           (ueof <> etok 'a')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           (utok c <> etok '-' <> eeof)++  describe "sepBy1" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepBy1 (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' && n >= 1 ->+         prs_ p s `shouldParse` replicate n 'a'+       | isNothing c' ->+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+       | c == '-' ->+         prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "sepEndBy" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepEndBy (char 'a') (char '-')+        a = replicate n 'a'+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' ->+         prs_ p s `shouldParse` a+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)+       | c == '-' ->+         prs_ p s `shouldParse` a+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "sepEndBy1" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepEndBy1 (char 'a') (char '-')+        a = replicate n 'a'+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' && n >= 1 ->+         prs_ p s `shouldParse` a+       | isNothing c' ->+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+       | c == '-' ->+         prs_ p s `shouldParse` a+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "skipMany" . it "works" . property $ \c n' a -> do+    let p = skipMany (char c) *> string a+        n = getNonNegative n'+        p' = many (char c) >> string a+        s = replicate n c ++ a+    prs_ p s `shouldBe` prs_ p' s++  describe "skipSome" . it "works" . property $ \c n' a -> do+    let p = skipSome (char c) *> string a+        n = getNonNegative n'+        p' = some (char c) >> string a+        s = replicate n c ++ a+    prs_ p s `shouldBe` prs_ p' s++  describe "skipManyTill" . it "works" . property $ \c n' a -> c /= a ==> do+    let p = skipManyTill (char c) (char a)+        n = getNonNegative n'+        s = replicate n c ++ [a]+    prs_ p s `shouldParse` a++  describe "skipSomeTill" . it "works" . property $ \c n' a -> c /= a ==> do+    let p = skipSomeTill (char c) (char a)+        n = getNonNegative n'+        s = replicate n c ++ [a]+    if n == 0+      then prs_ p s `shouldFailWith` err posI (utok a <> etok c)+      else prs_ p s `shouldParse` a++----------------------------------------------------------------------------+-- Helpers++g :: Int -> Int+g x = x + if x > 0 then x - 1 else 0
tests/Test/Hspec/Megaparsec.hs view
@@ -9,10 +9,7 @@ -- -- Utility functions for testing Megaparsec parsers with Hspec. -{-# LANGUAGE BangPatterns        #-} {-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -26,40 +23,19 @@   , shouldFailOn     -- * Testing of error messages   , shouldFailWith-    -- * Error message construction-    -- $errmsg-  , err-  , posI-  , posN-  , EC-  , utok-  , utoks-  , ulabel-  , ueof-  , etok-  , etoks-  , elabel-  , eeof-  , cstm     -- * Incremental parsing   , failsLeaving   , succeedsLeaving-  , initialState )+  , initialState+    -- * Re-exports+  , module Text.Megaparsec.Error.Builder ) where  import Control.Monad (unless)-import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..))-import Data.Proxy-import Data.Semigroup-import Data.Set (Set)-import Data.Typeable (Typeable)-import GHC.Generics import Test.Hspec.Expectations import Text.Megaparsec-import Text.Megaparsec.Pos (defaultTabWidth)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E+import Text.Megaparsec.Error.Builder  ---------------------------------------------------------------------------- -- Basic expectations@@ -139,141 +115,6 @@     "the parser is expected to fail, but it parsed: " ++ show v  ------------------------------------------------------------------------------- Error message construction---- $errmsg------ When you wish to test error message on failure, the need to construct a--- error message for comparison arises. These helpers allow to construct--- virtually any sort of error message easily.---- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To--- create source position, two helpers are available: 'posI' and 'posN'.--- @'EC' t e@ is a monoid and can be built from primitives provided by this--- module, see below.------ @since 0.3.0--err-  :: NonEmpty SourcePos -- ^ 'ParseError' position-  -> EC t e             -- ^ Error components-  -> ParseError t e     -- ^ Resulting 'ParseError'-err pos (EC u e c) = ParseError pos u e c---- | Initial source position with empty file name.------ @since 0.3.0--posI :: NonEmpty SourcePos-posI = initialPos "" :| []---- | @posN n s@ returns source position achieved by applying 'updatePos'--- method corresponding to type of stream @s@ @n@ times.------ @since 0.3.0--posN :: forall s n. (Stream s, Integral n)-  => n-  -> s-  -> NonEmpty SourcePos-posN n see = f (initialPos "") see n :| []-  where-    f p s !i =-      if i > 0-        then case uncons s of-          Nothing -> p-          Just (t,s') ->-            let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t-            in f p' s' (i - 1)-        else p---- | Auxiliary type for construction of 'ParseError's. Note that it's a--- monoid.------ @since 0.3.0--data EC t e = EC-  { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items-  , ecExpected   :: Set (ErrorItem t) -- ^ Expected items-  , _ecCustom    :: Set e             -- ^ Custom items-  } deriving (Eq, Data, Typeable, Generic)--instance (Ord t, Ord e) => Semigroup (EC t e) where-  (EC u0 e0 c0) <> (EC u1 e1 c1) =-    EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1)--instance (Ord t, Ord e) => Monoid (EC t e) where-  mempty  = EC E.empty E.empty E.empty-  mappend = (<>)---- | Construct an “unexpected token” error component.------ @since 0.3.0--utok :: (Ord t, Ord e) => t -> EC t e-utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t }---- | Construct an “unexpected tokens” error component. Empty string produces--- 'EndOfInput'.------ @since 0.3.0--utoks :: (Ord t, Ord e) => [t] -> EC t e-utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t }---- | Construct an “unexpected label” error component. Do not use with empty--- strings (for empty strings it's bottom).------ @since 0.3.0--ulabel :: (Ord t, Ord e) => String -> EC t e-ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l }---- | Construct an “unexpected end of input” error component.------ @since 0.3.0--ueof :: (Ord t, Ord e) => EC t e-ueof = mempty { ecUnexpected = E.singleton EndOfInput }---- | Construct an “expected token” error component.------ @since 0.3.0--etok :: (Ord t, Ord e) => t -> EC t e-etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t }---- | Construct an “expected tokens” error component. Empty string produces--- 'EndOfInput'.------ @since 0.3.0--etoks :: (Ord t, Ord e) => [t] -> EC t e-etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t }---- | Construct an “expected label” error component. Do not use with empty--- strings.------ @since 0.3.0--elabel :: (Ord t, Ord e) => String -> EC t e-elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l }---- | Construct an “expected end of input” error component.------ @since 0.3.0--eeof :: (Ord t, Ord e) => EC t e-eeof = mempty { ecExpected = E.singleton EndOfInput }---- | Construct a custom error component.------ @since 0.3.0--cstm :: e -> EC t e-cstm e = EC E.empty E.empty (E.singleton e)------------------------------------------------------------------------------ -- Incremental parsing  -- | Check that a parser fails and leaves a certain part of input@@ -368,20 +209,6 @@ -- suite report.  showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)-  => ParseError t e -> String+  => ParseError t e+  -> String showParseError = unlines . fmap ("  " ++) . lines . parseErrorPretty---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}---- | Construct appropriate 'ErrorItem' representation for given token--- stream. Empty string produces 'EndOfInput'.--canonicalizeTokens :: [t] -> ErrorItem t-canonicalizeTokens ts =-  case NE.nonEmpty ts of-    Nothing -> EndOfInput-    Just xs -> Tokens xs
tests/Test/Hspec/Megaparsec/AdHoc.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE RankNTypes           #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Hspec.Megaparsec.AdHoc   ( -- * Helpers to run parsers@@ -15,25 +16,32 @@   , nes     -- * Other   , abcRow-  , toFirstMismatch )+  , toFirstMismatch+  , Parser ) where  import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Identity-import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+import Data.Void import Test.Hspec import Test.Hspec.Megaparsec-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim+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@@ -46,20 +54,18 @@ -- that assumes empty file name.  prs-  :: Parsec Dec String a -- ^ Parser to run+  :: Parser a          -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> Either (ParseError Char Dec) a -- ^ Result of parsing+  -> Either (ParseError Char Void) a -- ^ Result of parsing prs p = parse p ""-{-# INLINE prs #-}  -- | Just like 'prs', but allows to inspect final state of the parser.  prs'-  :: Parsec Dec String a -- ^ Parser to run+  :: Parser a          -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing+  -> (State String, Either (ParseError Char Void) a) -- ^ Result of parsing prs' p s = runParser' p (initialState s)-{-# INLINE prs' #-}  -- | Just like 'prs', but forces the parser to consume all input by adding -- 'eof':@@ -67,19 +73,18 @@ -- > prs_ p = parse (p <* eof) ""  prs_-  :: Parsec Dec String a -- ^ Parser to run+  :: Parser a          -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> Either (ParseError Char Dec) a -- ^ Result of parsing+  -> Either (ParseError Char Void) a -- ^ Result of parsing prs_ p = parse (p <* eof) ""-{-# INLINE prs_ #-}  -- | Just like 'prs', but interprets given parser as various monads (tries -- all supported monads transformers in turn).  grs-  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run+  :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> (Either (ParseError Char Dec) a -> Expectation)+  -> (Either (ParseError Char Void) a -> Expectation)     -- ^ How to check result of parsing   -> Expectation grs p s r = do@@ -93,12 +98,12 @@   r (prs (evalRWSTL    p)    s)   r (prs (evalRWSTS    p)    s) --- | 'grs'' to 'grs' as 'prs'' to 'prs'.+-- | 'grs'' to 'grs' is as 'prs'' to 'prs'.  grs'-  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run+  :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> ((State String, Either (ParseError Char Dec) a) -> Expectation)+  -> ((State String, Either (ParseError Char Void) a) -> Expectation)     -- ^ How to check result of parsing   -> Expectation grs' p s r = do@@ -137,19 +142,12 @@   -> SourcePos         -- ^ Initial position   -> String            -- ^ 'String' — collection of tokens to process   -> SourcePos         -- ^ Final position-updatePosString w = foldl' f-  where f p t = snd (defaultUpdatePos w p t)---- | Position with minimal value.--pos1 :: Pos-pos1 = unsafePos 1+updatePosString = advanceN (Proxy :: Proxy String)  -- | Make a singleton non-empty list from a value.  nes :: a -> NonEmpty a nes x = x :| []-{-# INLINE nes #-}  ---------------------------------------------------------------------------- -- Other@@ -171,3 +169,72 @@   -> String            -- ^ Resulting prefix toFirstMismatch f str s = take (n + 1) s   where n = length (takeWhile (uncurry f) (zip str s))++-- | The type of parser that consumes a 'String'.++type Parser = Parsec Void String++----------------------------------------------------------------------------+-- Arbitrary instances++instance Arbitrary Void where+  arbitrary = error "Arbitrary Void"++instance Arbitrary Pos where+  arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))++instance Arbitrary SourcePos where+  arbitrary = SourcePos+    <$> sized (\n -> do+          k <- choose (0, n `div` 2)+          vectorOf k arbitrary)+    <*> arbitrary+    <*> arbitrary++instance Arbitrary t => Arbitrary (ErrorItem t) where+  arbitrary = oneof+    [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)+    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)+    , return EndOfInput ]++instance Arbitrary (ErrorFancy a) where+  arbitrary = oneof+    [ sized (\n -> do+        k <- choose (0, n `div` 2)+        ErrorFail <$> vectorOf k arbitrary)+    , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]++instance (Arbitrary t, Ord t, Arbitrary e, Ord e)+    => Arbitrary (ParseError t e) where+  arbitrary = oneof+    [ TrivialError+      <$> (NE.fromList . getNonEmpty <$> arbitrary)+      <*> arbitrary+      <*> (E.fromList <$> arbitrary)+    , FancyError+      <$> (NE.fromList . getNonEmpty <$> arbitrary)+      <*> (E.fromList <$> arbitrary) ]++instance Arbitrary a => Arbitrary (State a) where+  arbitrary = State+    <$> arbitrary+    <*> (NE.fromList . getNonEmpty <$> arbitrary)+    <*> choose (1, 10000)+    <*> (mkPos <$> choose (1, 20))++instance Arbitrary T.Text where+  arbitrary = T.pack <$> arbitrary++instance Arbitrary TL.Text where+  arbitrary = TL.pack <$> arbitrary++instance Arbitrary B.ByteString where+  arbitrary = B.pack <$> arbitrary++instance Arbitrary BL.ByteString where+  arbitrary = BL.pack <$> arbitrary++#if MIN_VERSION_QuickCheck(2,10,0)+instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null))+#endif
+ tests/Text/Megaparsec/Byte/LexerSpec.hs view
@@ -0,0 +1,262 @@+{-# 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 "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 "floating point number")+          prs' p s `failsLeaving` s+    context "when stream begins with a decimal number" $+      it "parses it" $+        property $ \n' -> do+          let p = float :: Parser Double+              n = getNonNegative n'+              s = B8.pack $ show (n :: Integer)+          prs  p s `shouldParse` fromIntegral n+          prs' p s `succeedsLeaving` ""+    context "when stream is empty" $+      it "signals correct parse error" $+        prs (float :: Parser Double) "" `shouldFailWith`+          err posI (ueof <> elabel "floating point number")+    context "when there is float with exponent without explicit sign" $+      it "parses it all right" $ do+        let p = float :: Parser Double+            s = "123e3"+        prs  p s `shouldParse` 123e3+        prs' p s `succeedsLeaving` ""++  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 stream is empty" $+      it "signals correct parse error" $+        prs (scientific :: Parser Scientific) "" `shouldFailWith`+          err posI (ueof <> elabel "digit")++  describe "signed" $ do+    context "with integer" $+      it "parses signed integers" $+        property $ \n -> do+          let p :: Parser Integer+              p = signed (hidden B.space) decimal+              s = B8.pack (show n)+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with float" $+      it "parses signed floats" $+        property $ \n -> do+          let p :: Parser Double+              p = signed (hidden B.space) float+              s = B8.pack (show n)+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with scientific" $+      it "parses singed scientific numbers" $+        property $ \n -> do+          let p = signed (hidden B.space) scientific+              s = B8.pack $ either show show (n :: Either Integer Double)+          prs p s `shouldParse` case n of+            Left  x -> fromIntegral    x+            Right x -> fromFloatDigits x+    context "when number is prefixed with plus sign" $+      it "parses the number" $+        property $ \n' -> do+          let p :: Parser Integer+              p = signed (hidden B.space) decimal+              n = getNonNegative n'+              s = B8.pack ('+' : show n)+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when number is prefixed with white space" $+      it "signals correct parse error" $+        property $ \n -> do+          let p :: Parser Integer+              p = signed (hidden B.space) decimal+              s = B8.pack (' ' : show (n :: Integer))+          prs  p s `shouldFailWith` err posI+            (utok 32 <> etok 43 <> etok 45 <> elabel "integer")+          prs' p s `failsLeaving` s+    context "when there is white space between sign and digits" $+      it "parses it all right" $ do+        let p :: Parser Integer+            p = signed (hidden B.space) decimal+            s = "- 123"+        prs  p s `shouldParse` (-123)+        prs' p s `succeedsLeaving` ""++----------------------------------------------------------------------------+-- Helpers++prs+  :: Parser a          -- ^ Parser to run+  -> ByteString        -- ^ Input for the parser+  -> Either (ParseError Word8 Void) a -- ^ Result of parsing+prs p = parse p ""++prs'+  :: Parser a          -- ^ Parser to run+  -> ByteString        -- ^ Input for the parser+  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing+prs' p s = runParser' p (initialState s)++isDigit :: Word8 -> Bool+isDigit w = w - 48 < 10++isOctDigit :: Word8 -> Bool+isOctDigit w = w - 48 < 8++isHexDigit :: Word8 -> Bool+isHexDigit w =+  (w >= 48 && w <= 57)  ||+  (w >= 97 && w <= 102) ||+  (w >= 65 && w <= 70)
+ tests/Text/Megaparsec/ByteSpec.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.ByteSpec (spec) where++import Control.Monad+import Data.ByteString (ByteString)+import Data.Char+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Semigroup ((<>))+import Data.Void+import Data.Word (Word8)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc (nes)+import Test.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Byte+import qualified Data.ByteString as B++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++type Parser = Parsec Void ByteString++spec :: Spec+spec = do++  describe "newline" $+    checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline)++  describe "csrf" $+    checkStrLit "crlf newline" "\r\n" crlf++  describe "eol" $ do+    context "when stream begins with a newline" $+      it "succeeds returning the newline" $+        property $ \s -> do+          let s' = "\n" <> s+          prs  eol s' `shouldParse`     "\n"+          prs' eol s' `succeedsLeaving` s+    context "when stream begins with CRLF sequence" $+      it "parses the CRLF sequence" $+        property $ \s -> do+          let s' = "\r\n" <> s+          prs  eol s' `shouldParse`     "\r\n"+          prs' eol s' `succeedsLeaving` s+    context "when stream begins with '\\r', but it's not followed by '\\n'" $+      it "signals correct parse error" $+        property $ \ch -> ch /= 10 ==> do+          let s = "\r" <> B.singleton ch+          prs eol s `shouldFailWith`+            err posI (utoks (B.unpack s) <> elabel "end of line")+    context "when input stream is '\\r'" $+      it "signals correct parse error" $+        prs eol "\r" `shouldFailWith` err posI+          (utok 13 <> elabel "end of line")+    context "when stream does not begin with newline or CRLF sequence" $+      it "signals correct parse error" $+        property $ \ch s -> (ch /= 13 && ch /= 10) ==> do+          let s' = B.singleton ch <> s+          prs eol s' `shouldFailWith` err posI+            (utoks (B.unpack $ B.take 2 s') <> elabel "end of line")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs eol "" `shouldFailWith` err posI+          (ueof <> elabel "end of line")++  describe "tab" $+    checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)++  describe "space" $+    it "consumes space up to first non-space character" $+      property $ \s' -> do+        let (s0,s1) = B.partition isSpace' s'+            s = s0 <> s1+        prs  space s `shouldParse` ()+        prs' space s `succeedsLeaving` s1++  describe "space1" $ do+    context "when stream does not start with a space character" $+      it "signals correct parse error" $+        property $ \ch s' -> not (isSpace' ch) ==> do+          let (s0,s1) = B.partition isSpace' s'+              s = B.singleton ch <> s0 <> s1+          prs  space1 s `shouldFailWith` err posI (utok ch <> elabel "white space")+          prs' space1 s `failsLeaving` s+    context "when stream starts with a space character" $+      it "consumes space up to first non-space character" $+        property $ \s' -> do+          let (s0,s1) = B.partition isSpace' s'+              s = " " <> s0 <> s1+          prs  space1 s `shouldParse` ()+          prs' space1 s `succeedsLeaving` s1+    context "when stream is empty" $+      it "signals correct parse error" $+        prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space")++  describe "controlChar" $+    checkCharPred "control character" (isControl . toChar) controlChar++  describe "spaceChar" $+    checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar++  -- describe "upperChar" $+  --   checkCharPred "uppercase letter" (isUpper . toChar) upperChar++  -- describe "lowerChar" $+  --   checkCharPred "lowercase letter" (isLower . toChar) lowerChar++  -- describe "letterChar" $+  --   checkCharPred "letter" (isAlpha . toChar) letterChar++  describe "alphaNumChar" $+    checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar++  describe "printChar" $+    checkCharPred "printable character" (isPrint . toChar) printChar++  describe "digitChar" $+    checkCharRange "digit" [48..57] digitChar++  describe "octDigitChar" $+    checkCharRange "octal digit" [48..55] octDigitChar++  describe "hexDigitChar" $+    checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar++  -- describe "asciiChar" $+  --   checkCharPred "ASCII character" (isAscii . toChar) asciiChar++  describe "char'" $ do+    context "when stream begins with the character specified as argument" $+      it "parses the character" $+        property $ \ch s -> do+          let sl = B.cons (liftChar toLower ch) s+              su = B.cons (liftChar toUpper ch) s+          prs  (char' ch) sl `shouldParse`     liftChar toLower ch+          prs  (char' ch) su `shouldParse`     liftChar toUpper ch+          prs' (char' ch) sl `succeedsLeaving` s+          prs' (char' ch) su `succeedsLeaving` s+    context "when stream does not begin with the character specified as argument" $+      it "signals correct parse error" $+        property $ \ch ch' s -> liftChar toLower ch /= liftChar toLower ch' ==> do+          let s' = B.cons ch' s+              ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)+          prs  (char' ch) s' `shouldFailWith` err posI ms+          prs' (char' ch) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \ch -> do+          let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)+          prs  (char' ch) "" `shouldFailWith` err posI ms++----------------------------------------------------------------------------+-- Helpers++checkStrLit :: String -> ByteString -> Parser ByteString -> SpecWith ()+checkStrLit name ts p = do+  context ("when stream begins with " ++ name) $+    it ("parses the " ++ name) $+      property $ \s -> do+        let s' = ts <> s+        prs  p s' `shouldParse`     ts+        prs' p s' `succeedsLeaving` s+  context ("when stream does not begin with " ++ name) $+    it "signals correct parse error" $+      property $ \ch s -> ch /= B.head ts ==> do+       let s' = B.cons ch s+           us = B.unpack $ B.take (B.length ts) s'+           ps = B.unpack ts+       prs  p s' `shouldFailWith` err posI (utoks us <> etoks ps)+       prs' p s' `failsLeaving`   s'+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (ueof <> etoks (B.unpack ts))++checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith ()+checkCharPred name f p = do+  context ("when stream begins with " ++ name) $+    it ("parses the " ++ name) $+      property $ \ch s -> f ch ==> do+        let s' = B.singleton ch <> s+        prs  p s' `shouldParse`     ch+        prs' p s' `succeedsLeaving` s+  context ("when stream does not begin with " ++ name) $+    it "signals correct parse error" $+      property $ \ch s -> not (f ch) ==> do+       let s' = B.singleton ch <> s+       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)+       prs' p s' `failsLeaving`   s'+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (ueof <> elabel name)++checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith ()+checkCharRange name tchs p = do+  forM_ tchs $ \tch ->+    context ("when stream begins with " ++ showTokens (nes tch)) $+      it ("parses the " ++ showTokens (nes tch)) $+        property $ \s -> do+          let s' = B.singleton tch <> s+          prs  p s' `shouldParse`     tch+          prs' p s' `succeedsLeaving` s+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (ueof <> elabel name)++prs+  :: Parser a          -- ^ Parser to run+  -> ByteString        -- ^ Input for the parser+  -> Either (ParseError Word8 Void) a -- ^ Result of parsing+prs p = parse p ""++prs'+  :: Parser a          -- ^ Parser to run+  -> ByteString        -- ^ Input for the parser+  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing+prs' p s = runParser' p (initialState s)++bproxy :: Proxy ByteString+bproxy = Proxy++-- | 'Word8'-specialized version of 'isSpace'.++isSpace' :: Word8 -> Bool+isSpace' x+  | x >= 9 && x <= 13 = True+  | x == 32           = True+  | x == 160          = True+  | otherwise         = False++-- | Convert a byte to char.++toChar :: Word8 -> Char+toChar = chr . fromIntegral++-- | Covert a char to byte.++fromChar :: Char -> Maybe Word8+fromChar x = let p = ord x in+  if p > 0xff+    then Nothing+    else Just (fromIntegral p)++-- | Lift char transformation to byte transformation.++liftChar :: (Char -> Char) -> Word8 -> Word8+liftChar f x = (fromMaybe x . fromChar . f . toChar) x
+ tests/Text/Megaparsec/Char/LexerSpec.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf       #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE TypeFamilies     #-}++module Text.Megaparsec.Char.LexerSpec (spec) where++import Control.Applicative+import Control.Monad (void)+import Data.Char hiding (ord)+import Data.List (isInfixOf)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Scientific (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++spec :: Spec+spec = do++  describe "space" $+    it "consumes any sort of white space" $+      property $ forAll mkWhiteSpace $ \s -> do+        prs  scn s `shouldParse` ()+        prs' scn s `succeedsLeaving` ""++  describe "symbol" $+    context "when stream begins with the symbol" $+      it "parses the symbol and trailing whitespace" $+        property $ forAll mkSymbol $ \s -> do+          let p = symbol scn y+              y = takeWhile (not . isSpace) s+          prs  p s `shouldParse` y+          prs' p s `succeedsLeaving` ""++  describe "symbol'" $+    context "when stream begins with the symbol" $+      it "parses the symbol and trailing whitespace" $+        property $ forAll mkSymbol $ \s -> do+          let p = symbol' scn (toUpper <$> y)+              y = takeWhile (not . isSpace) s+          prs  p s `shouldParse` y+          prs' p s `succeedsLeaving` ""++  describe "skipLineComment" $ 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 "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 "floating point number")+          prs' p s `failsLeaving` s+    context "when stream begins with a decimal number" $+      it "parses it" $+        property $ \n' -> do+          let p = float :: Parser Double+              n = getNonNegative n'+              s = show (n :: Integer)+          prs  p s `shouldParse` fromIntegral n+          prs' p s `succeedsLeaving` ""+    context "when stream is empty" $+      it "signals correct parse error" $+        prs (float :: Parser Double) "" `shouldFailWith`+          err posI (ueof <> elabel "floating point number")+    context "when there is float with exponent without explicit sign" $+      it "parses it all right" $ do+        let p = float :: Parser Double+            s = "123e3"+        prs  p s `shouldParse` 123e3+        prs' p s `succeedsLeaving` ""++  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 stream is empty" $+      it "signals correct parse error" $+        prs (scientific :: Parser Scientific) "" `shouldFailWith`+          err posI (ueof <> elabel "digit")++  describe "signed" $ do+    context "with integer" $+      it "parses signed integers" $+        property $ \n -> do+          let p :: Parser Integer+              p = signed (hidden C.space) decimal+              s = show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with float" $+      it "parses signed floats" $+        property $ \n -> do+          let p :: Parser Double+              p = signed (hidden C.space) float+              s = show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with scientific" $+      it "parses singed scientific numbers" $+        property $ \n -> do+          let p = signed (hidden C.space) scientific+              s = either show show (n :: Either Integer Double)+          prs p s `shouldParse` case n of+            Left  x -> fromIntegral    x+            Right x -> fromFloatDigits x+    context "when number is prefixed with plus sign" $+      it "parses the number" $+        property $ \n' -> do+          let p :: Parser Integer+              p = signed (hidden C.space) decimal+              n = getNonNegative n'+              s = '+' : show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when number is prefixed with white space" $+      it "signals correct parse error" $+        property $ \n -> do+          let p :: Parser Integer+              p = signed (hidden C.space) decimal+              s = ' ' : show (n :: Integer)+          prs  p s `shouldFailWith` err posI+            (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")+          prs' p s `failsLeaving` s+    context "when there is white space between sign and digits" $+      it "parses it all right" $ do+        let p :: Parser Integer+            p = signed (hidden C.space) decimal+            s = "- 123"+        prs  p s `shouldParse` (-123)+        prs' p s `succeedsLeaving` ""++----------------------------------------------------------------------------+-- Helpers++mkWhiteSpace :: Gen String+mkWhiteSpace = concat <$> listOf whiteUnit+  where+    whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]++mkWhiteSpaceNl :: Gen String+mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n"++mkSymbol :: Gen String+mkSymbol = (++) <$> symbolName <*> whiteChars++mkInterspace :: String -> Int -> Gen String+mkInterspace x n = oneof [si, mkIndent x n]+  where+    si = (++ x) <$> listOf (elements " \t")++mkIndent :: String -> Int -> Gen String+mkIndent x n = (++) <$> mkIndent' x n <*> eol+  where+    eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]++mkIndent' :: String -> Int -> Gen String+mkIndent' x n = concat <$> sequence [spc, sym, tra]+  where+    spc = frequency [(5, vectorOf n itm), (1, listOf itm)]+    tra = listOf itm+    itm = elements " \t"+    sym = return x++whiteChars :: Gen String+whiteChars = listOf (elements "\t\n ")++whiteLine :: Gen String+whiteLine = commentOut <$> arbitrary `suchThat` goodEnough+  where+    commentOut x = "//" ++ x ++ "\n"+    goodEnough x = '\n' `notElem` x++whiteBlock :: Gen String+whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough+  where+    commentOut x = "/*" ++ x ++ "*/"+    goodEnough x = not $ "*/" `isInfixOf` x++symbolName :: Gen String+symbolName = listOf $ arbitrary `suchThat` isAlphaNum++sc :: Parser ()+sc = space (void $ takeWhile1P Nothing f) empty empty+  where+    f x = x == ' ' || x == '\t'++scn :: Parser ()+scn = space C.space1 l b+  where+    l = skipLineComment "//"+    b = skipBlockComment "/*" "*/"++getIndent :: String -> Int+getIndent = length . takeWhile isSpace++getCol :: String -> Pos+getCol x = sourceColumn .+  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x++sbla, sblb, sblc :: String+sbla = "aaa"+sblb = "bbb"+sblc = "ccc"++ii :: Ordering -> Pos -> Pos -> EF Void+ii ord ref actual = fancy (ErrorIndentation ord ref actual)
tests/Text/Megaparsec/CharSpec.hs view
@@ -11,9 +11,8 @@ import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck+import Text.Megaparsec import Text.Megaparsec.Char-import Text.Megaparsec.Error-import Text.Megaparsec.Prim  #if !MIN_VERSION_base(4,8,0) import Control.Applicative@@ -48,8 +47,7 @@       it "signals correct parse error" $         property $ \ch -> ch /= '\n' ==> do           let s = ['\r',ch]-          prs eol s `shouldFailWith` err posI-            (utoks s <> utok '\r' <> elabel "end of line")+          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@@ -59,7 +57,7 @@         property $ \ch s -> (ch `notElem` "\r\n") ==> do           let s' = ch : s           prs eol s' `shouldFailWith` err posI-            (utok ch <> elabel "end of line")+            (utoks (take 2 s') <> elabel "end of line")     context "when stream is empty" $       it "signals correct parse error" $         prs eol "" `shouldFailWith` err posI@@ -69,13 +67,32 @@     checkStrLit "tab" "\t" (pure <$> tab)    describe "space" $-    it "consumes it up to first non-space character" $-      property $ \s -> do-        let (s0,s1) = partition isSpace s-            s' = s0 ++ s1-        prs  space s' `shouldParse` ()-        prs' space s' `succeedsLeaving` s1+    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 @@ -221,6 +238,24 @@       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" $@@ -241,29 +276,6 @@         property $ \chs ->           prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof -  describe "oneOf'" $ do-    context "when stream begins with one of specified characters" $-      it "parses the character" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              sl  = toLower ch : s-              su  = toUpper ch : s-          prs  (oneOf' chs) sl `shouldParse`     toLower ch-          prs  (oneOf' chs) su `shouldParse`     toUpper ch-          prs' (oneOf' chs) sl `succeedsLeaving` s-          prs' (oneOf' chs) su `succeedsLeaving` s-    context "when stream does not begin with any of specified characters" $-      it "signals correct parse error" $-        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do-          let s' = ch : s-          prs  (oneOf' chs) s' `shouldFailWith` err posI (utok ch)-          prs' (oneOf' chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (oneOf' (chs :: String)) "" `shouldFailWith` err posI ueof-   describe "noneOf" $ do     context "when stream does not begin with any of specified characters" $       it "parses the character" $@@ -284,29 +296,6 @@         property $ \chs ->           prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof -  describe "noneOf'" $ do-    context "when stream does not begin with any of specified characters" $-      it "parses the character" $-        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do-          let sl  = toLower ch : s-              su  = toUpper ch : s-          prs  (noneOf' chs) sl `shouldParse`     toLower ch-          prs  (noneOf' chs) su `shouldParse`     toUpper ch-          prs' (noneOf' chs) sl `succeedsLeaving` s-          prs' (noneOf' chs) su `succeedsLeaving` s-    context "when stream begins with one of specified characters" $-      it "signals correct parse error" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              s'  = ch : s-          prs  (noneOf' chs) s' `shouldFailWith` err posI (utok ch)-          prs' (noneOf' chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (noneOf' (chs :: String)) "" `shouldFailWith` err posI ueof-   describe "string" $ do     context "when stream is prefixed with given string" $       it "parses the string" $@@ -317,9 +306,9 @@     context "when stream is not prefixed with given string" $       it "signals correct parse error" $         property $ \str s -> not (str `isPrefixOf` s) ==> do-          let n = length (takeWhile (uncurry (==)) (zip str s)) + 1-              common = take n s-          prs  (string str) s `shouldFailWith` err posI (utoks common <> etoks str)+          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" $@@ -332,14 +321,14 @@     context "when stream is not prefixed with given string" $       it "signals correct parse error" $         property $ \str s -> not (str `isPrefixOfI` s) ==> do-          let n = length (takeWhile (uncurry casei) (zip str s)) + 1-              common = take n s-          prs  (string' str) s `shouldFailWith` err posI (utoks common <> etoks str)+          let us = take (length str) s+          prs  (string' str) s `shouldFailWith`+            err posI (utoks us <> etoks str)  ---------------------------------------------------------------------------- -- Helpers -checkStrLit :: String -> String -> Parsec Dec String String -> SpecWith ()+checkStrLit :: String -> String -> Parser String -> SpecWith () checkStrLit name ts p = do   context ("when stream begins with " ++ name) $     it ("parses the " ++ name) $@@ -351,13 +340,14 @@     it "signals correct parse error" $       property $ \ch s -> ch /= head ts ==> do        let s' = ch : s-       prs  p s' `shouldFailWith` err posI (utok ch <> etoks ts)+           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) -> Parsec Dec String Char -> SpecWith ()+checkCharPred :: String -> (Char -> Bool) -> Parser Char -> SpecWith () checkCharPred name f p = do   context ("when stream begins with " ++ name) $     it ("parses the " ++ name) $@@ -375,7 +365,7 @@     it "signals correct parse error" $       prs p "" `shouldFailWith` err posI (ueof <> elabel name) -checkCharRange :: String -> String -> Parsec Dec String Char -> SpecWith ()+checkCharRange :: String -> String -> Parser Char -> SpecWith () checkCharRange name tchs p = do   forM_ tchs $ \tch ->     context ("when stream begins with " ++ showTokens (nes tch)) $@@ -384,12 +374,6 @@           let s' = tch : s           prs  p s' `shouldParse`     tch           prs' p s' `succeedsLeaving` s-  -- context ("when stream does not begin with " ++ name) $-  --   it "signals correct parse error" $-  --     property $ \ch s -> ch `notElem` tchs ==> do-  --      let s' = ch : s-  --      prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)-  --      prs' p s' `failsLeaving`   s'   context "when stream is empty" $     it "signals correct parse error" $       prs p "" `shouldFailWith` err posI (ueof <> elabel name)@@ -398,23 +382,14 @@  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+  where+    f k True  = if isLower k then toUpper k else toLower k+    f k False = k  -- | Case-insensitive equality test for characters.  casei :: Char -> Char -> Bool casei x y = toUpper x == toUpper y---- | Case-insensitive 'elem'.--elemi :: Char -> String -> Bool-elemi c = any (casei c)---- | Case-insensitive 'notElem'.--notElemi :: Char -> String -> Bool-notElemi c = not . elemi c  -- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff -- the first list is a prefix of the second with case-insensitive
− tests/Text/Megaparsec/CombinatorSpec.hs 
@@ -1,228 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--module Text.Megaparsec.CombinatorSpec (spec) where--import Control.Applicative-import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)-import Data.Monoid-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char-import Text.Megaparsec.Combinator--spec :: Spec-spec = do--  describe "between" . it "works" . property $ \pre c n' post -> do-    let p = between (string pre) (string post) (many (char c))-        n = getNonNegative n'-        b = length (takeWhile (== c) post)-        z = replicate n c-        s = pre ++ z ++ post-    if b > 0-      then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s)-        ( etoks post <> etok c <>-          (if length post == b then ueof else utoks [post !! b]) )-      else prs_ p s `shouldParse` z--  describe "choice" . it "works" . property $ \cs' s' -> do-    let cs = getNonEmpty cs'-        p = choice (char <$> cs)-        s = [s']-    if s' `elem` cs-      then prs_ p s `shouldParse` s'-      else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs))--  describe "count" . it "works" . property $ \n x' -> do-    let x = getNonNegative x'-        p = count n (char 'x')-        p' = count' n n (char 'x')-        s = replicate x 'x'-    prs_ p s `shouldBe` prs_ p' s--  describe "count'" . it "works" . property $ \m n x' -> do-    let x = getNonNegative x'-        p = count' m n (char 'x')-        s = replicate x 'x'-    if | n <= 0 || m > n ->-         if x == 0-           then prs_ p s `shouldParse` ""-           else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)-       | m <= x && x <= n ->-         prs_ p s `shouldParse` s-       | x < m ->-         prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')-       | otherwise ->-         prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)--  describe "eitherP" . it "works" . property $ \ch -> do-    let p = eitherP letterChar digitChar-        s = pure ch-    if | isLetter ch -> prs_ p s `shouldParse` Left ch-       | isDigit  ch -> prs_ p s `shouldParse` Right ch-       | otherwise   -> prs_ p s `shouldFailWith`-         err posI (utok ch <> elabel "letter" <> elabel "digit")--  describe "endBy" . it "works" . property $ \n' c -> do-    let n = getNonNegative n'-        p = endBy (char 'a') (char '-')-        s = intersperse '-' (replicate n 'a') ++ [c]-    if | c == 'a' && n == 0 ->-         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-       | c == 'a' ->-         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-       | c == '-' && n == 0 ->-         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)-       | c /= '-' ->-         prs_ p s `shouldFailWith` err (posN (g n) s)-           ( utok c <>-             (if n > 0 then etok '-' else eeof) <>-             (if n == 0 then etok 'a' else mempty) )-       | otherwise -> prs_ p s `shouldParse` replicate n 'a'--  describe "endBy1" . it "works" . property $ \n' c -> do-    let n = getNonNegative n'-        p = endBy1 (char 'a') (char '-')-        s = intersperse '-' (replicate n 'a') ++ [c]-    if | c == 'a' && n == 0 ->-         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')-       | c == 'a' ->-         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')-       | c == '-' && n == 0 ->-         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')-       | c /= '-' ->-         prs_ p s `shouldFailWith` err (posN (g n) s)-           ( utok c <>-             (if n > 0 then etok '-' else mempty) <>-             (if n == 0 then etok 'a' else mempty) )-       | otherwise -> prs_ p s `shouldParse` replicate n 'a'--  describe "manyTill" . it "works" . property $ \a' b' c' -> do-    let [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar-        s = abcRow a b c-    if c == 0-      then prs_ p s `shouldFailWith` err (posN (a + b) s)-           (ueof <> etok 'c' <> elabel "letter")-      else let (pre, post) = break (== 'c') s-           in prs_ p s `shouldParse` (pre, drop 1 post)--  describe "someTill" . it "works" . property $ \a' b' c' -> do-    let [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar-        s = abcRow a b c-    if | null s ->-         prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")-       | c == 0 ->-         prs_ p s `shouldFailWith` err (posN (a + b) s)-           (ueof <> etok 'c' <> elabel "letter")-       | s == "c" ->-         prs_ p s `shouldFailWith` err-           (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")-       | head s == 'c' ->-         prs_ p s `shouldParse` ("c", drop 2 s)-       | otherwise ->-         let (pre, post) = break (== 'c') s-         in prs_ p s `shouldParse` (pre, drop 1 post)--  describe "option" . it "works" . property $ \d a s -> do-    let p = option d (string a)-        p' = fromMaybe d <$> optional (string a)-    prs_ p s `shouldBe` prs_ p' s--  describe "sepBy" . it "works" . property $ \n' c' -> do-    let n = getNonNegative n'-        c = fromJust c'-        p = sepBy (char 'a') (char '-')-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'-    if | isNothing c' ->-         prs_ p s `shouldParse` replicate n 'a'-       | c == 'a' && n == 0 ->-         prs_ p s `shouldParse` "a"-       | n == 0 ->-         prs_ p s `shouldFailWith` err posI-           (utok c <> etok 'a' <> eeof)-       | c == '-' ->-         prs_ p s `shouldFailWith` err (posN (length s) s)-           (ueof <> etok 'a')-       | otherwise ->-         prs_ p s `shouldFailWith` err (posN (g n) s)-           (utok c <> etok '-' <> eeof)--  describe "sepBy1" . it "works" . property $ \n' c' -> do-    let n = getNonNegative n'-        c = fromJust c'-        p = sepBy1 (char 'a') (char '-')-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'-    if | isNothing c' && n >= 1 ->-         prs_ p s `shouldParse` replicate n 'a'-       | isNothing c' ->-         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-       | c == 'a' && n == 0 ->-         prs_ p s `shouldParse` "a"-       | n == 0 ->-         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-       | c == '-' ->-         prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')-       | otherwise ->-         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)--  describe "sepEndBy" . it "works" . property $ \n' c' -> do-    let n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy (char 'a') (char '-')-        a = replicate n 'a'-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'-    if | isNothing c' ->-         prs_ p s `shouldParse` a-       | c == 'a' && n == 0 ->-         prs_ p s `shouldParse` "a"-       | n == 0 ->-         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)-       | c == '-' ->-         prs_ p s `shouldParse` a-       | otherwise ->-         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)--  describe "sepEndBy1" . it "works" . property $ \n' c' -> do-    let n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy1 (char 'a') (char '-')-        a = replicate n 'a'-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'-    if | isNothing c' && n >= 1 ->-         prs_ p s `shouldParse` a-       | isNothing c' ->-         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')-       | c == 'a' && n == 0 ->-         prs_ p s `shouldParse` "a"-       | n == 0 ->-         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')-       | c == '-' ->-         prs_ p s `shouldParse` a-       | otherwise ->-         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)--  describe "skipMany" . it "works" . property $ \c n' a -> do-    let p = skipMany (char c) *> string a-        n = getNonNegative n'-        p' = many (char c) >> string a-        s = replicate n c ++ a-    prs_ p s `shouldBe` prs_ p' s--  describe "skipSome" . it "works" . property $ \c n' a -> do-    let p = skipSome (char c) *> string a-        n = getNonNegative n'-        p' = some (char c) >> string a-        s = replicate n c ++ a-    prs_ p s `shouldBe` prs_ p' s--------------------------------------------------------------------------------- Helpers--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0
tests/Text/Megaparsec/ErrorSpec.hs view
@@ -1,18 +1,22 @@-{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}  module Text.Megaparsec.ErrorSpec (spec) where +import Data.ByteString (ByteString) import Data.Char (isControl, isSpace)-import Data.Function (on) import Data.List (isInfixOf, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid-import Data.Set (Set)+import 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@@ -24,7 +28,8 @@ import Control.Exception (Exception (..)) #endif -type PE = ParseError Char Dec+type PE = ParseError Char Void+type PW = ParseError Word8 Void  spec :: Spec spec = do@@ -54,33 +59,59 @@     it "selects greater source position" $       property $ \x y ->         errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)-    it "merges unexpected items correctly" $-      property (checkMergedItems errorUnexpected)-    it "merges expected items correctly" $-      property (checkMergedItems errorExpected)-    it "merges custom items correctly" $-      property (checkMergedItems errorCustom)+    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 x y = showTokens (NE.fromList x) `shouldBe` y+    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 (control character)")+      (f "\NUL" "null")     it "shows start of heading correctly"-      (f "\SOH" "start of heading (control character)")+      (f "\SOH" "start of heading")     it "shows start of text correctly"-      (f "\STX" "start of text (control character)")+      (f "\STX" "start of text")     it "shows end of text correctly"-      (f "\ETX" "end of text (control character)")+      (f "\ETX" "end of text")     it "shows end of transmission correctly"-      (f "\EOT" "end of transmission (control character)")+      (f "\EOT" "end of transmission")     it "shows enquiry correctly"-      (f "\ENQ" "enquiry (control character)")+      (f "\ENQ" "enquiry")     it "shows acknowledge correctly"-      (f "\ACK" "acknowledge (control character)")+      (f "\ACK" "acknowledge")     it "shows bell correctly"-      (f "\BEL" "bell (control character)")+      (f "\BEL" "bell")     it "shows backspace correctly"       (f "\BS" "backspace")     it "shows tab correctly"@@ -90,47 +121,47 @@     it "shows vertical tab correctly"       (f "\v" "vertical tab")     it "shows form feed correctly"-      (f "\f" "form feed (control character)")+      (f "\f" "form feed")     it "shows carriage return correctly"       (f "\r" "carriage return")     it "shows shift out correctly"-      (f "\SO" "shift out (control character)")+      (f "\SO" "shift out")     it "shows shift in correctly"-      (f "\SI" "shift in (control character)")+      (f "\SI" "shift in")     it "shows data link escape correctly"-      (f "\DLE" "data link escape (control character)")+      (f "\DLE" "data link escape")     it "shows device control one correctly"-      (f "\DC1" "device control one (control character)")+      (f "\DC1" "device control one")     it "shows device control two correctly"-      (f "\DC2" "device control two (control character)")+      (f "\DC2" "device control two")     it "shows device control three correctly"-      (f "\DC3" "device control three (control character)")+      (f "\DC3" "device control three")     it "shows device control four correctly"-      (f "\DC4" "device control four (control character)")+      (f "\DC4" "device control four")     it "shows negative acknowledge correctly"-      (f "\NAK" "negative acknowledge (control character)")+      (f "\NAK" "negative acknowledge")     it "shows synchronous idle correctly"-      (f "\SYN" "synchronous idle (control character)")+      (f "\SYN" "synchronous idle")     it "shows end of transmission block correctly"-      (f "\ETB" "end of transmission block (control character)")+      (f "\ETB" "end of transmission block")     it "shows cancel correctly"-      (f "\CAN" "cancel (control character)")+      (f "\CAN" "cancel")     it "shows end of medium correctly"-      (f "\EM"  "end of medium (control character)")+      (f "\EM"  "end of medium")     it "shows substitute correctly"-      (f "\SUB" "substitute (control character)")+      (f "\SUB" "substitute")     it "shows escape correctly"-      (f "\ESC" "escape (control character)")+      (f "\ESC" "escape")     it "shows file separator correctly"-      (f "\FS"  "file separator (control character)")+      (f "\FS"  "file separator")     it "shows group separator correctly"-      (f "\GS"  "group separator (control character)")+      (f "\GS"  "group separator")     it "shows record separator correctly"-      (f "\RS"  "record separator (control character)")+      (f "\RS"  "record separator")     it "shows unit separator correctly"-      (f "\US"  "unit separator (control character)")+      (f "\US"  "unit separator")     it "shows delete correctly"-      (f "\DEL" "delete (control character)")+      (f "\DEL" "delete")     it "shows space correctly"       (f " "    "space")     it "shows non-breaking space correctly"@@ -138,12 +169,23 @@     it "shows other single characters in single quotes" $       property $ \ch ->         not (isControl ch) && not (isSpace ch) ==>-          showTokens (ch :| []) === ['\'',ch,'\'']+          showTokens (ch :| []) === "\'" <> [ch] <> "\'"     it "shows strings in double quotes" $-      property $ \str ->-        (length str > 1) && (str /= "\r\n") ==>-          showTokens (NE.fromList str) === ("\"" ++ str ++"\"")+      property $ \str' ->+        let str = filter (not . g) str'+            g x = isControl x || x `elem` ['\160']+        in length str > 1 ==>+             showTokens (NE.fromList str) === ("\"" <> str <> "\"")+    it "shows control characters in long strings property"+      (f "{\n" "\"{<newline>\"") +  describe "showTokens (Word8 instance)" $+    it "basically works" $ do+      -- NOTE Currently the Word8 instance is defined via Char intance, so+      -- the testing is rather shallow.+      let ts = NE.fromList [10,48,49,50] :: NonEmpty Word8+      showTokens ts `shouldBe` "\"<newline>012\""+   describe "parseErrorPretty" $ do     it "shows unknown ParseError correctly" $       parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"@@ -152,13 +194,67 @@         parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)     it "result contains representation of source pos stack" $       property (contains errorPos sourcePosPretty)-    it "result contains representation of unexpected items" $-      property (contains errorUnexpected showErrorComponent)-    it "result contains representation of expected items" $-      property (contains errorExpected showErrorComponent)-    it "result contains representation of custom items" $-      property (contains errorCustom showErrorComponent)+    it "result contains representation of unexpected items" $ do+      let f (TrivialError _ us _) = us+          f _                     = Nothing+      property (contains f showErrorComponent)+    it "result contains representation of expected items" $ do+      let f (TrivialError _ _ ps) = ps+          f _                     = E.empty+      property (contains f showErrorComponent)+    it "result contains representation of custom items" $ do+      let f (FancyError _ xs) = xs+          f _                 = E.empty+      property (contains f showErrorComponent)+    it "several fancy errors look not so bad" $ do+      let pe :: PE+          pe = errFancy posI $+            mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")+      parseErrorPretty pe `shouldBe` "1:1:\nbar\nfoo\n" +  describe "parseErrorPretty'" $ do+    context "with Char tokens" $ do+      it "shows empty line correctly" $ do+        let s = "" :: String+        parseErrorPretty' s (mempty :: PE) `shouldBe`+          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"+      it "shows position on first line correctly" $ do+        let s = "abc" :: String+            pe = err (posN 1 s) (utok 'b' <> etok 'd') :: PE+        parseErrorPretty' s pe `shouldBe`+          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"+      it "skips to second line correctly" $ do+        let s = "one\ntwo\n" :: String+            pe = err (posN 4 s) (utok 't' <> etok 'x') :: PE+        parseErrorPretty' s pe `shouldBe`+          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"+      it "shows position on 1000 line correctly" $ do+        let s = replicate 999 '\n' ++ "abc"+            pe :: PE+            pe = err (posN 999 s) (utok 'a' <> etok 'd')+        parseErrorPretty' s pe `shouldBe`+          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"+    context "with Word8 tokens" $ do+      it "shows empty line correctly" $ do+        let s = "" :: ByteString+        parseErrorPretty' s (mempty :: PW) `shouldBe`+          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"+      it "shows position on first line correctly" $ do+        let s = "abc" :: ByteString+            pe = err (posN 1 s) (utok 98 <> etok 100) :: PW+        parseErrorPretty' s pe `shouldBe`+          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"+      it "skips to second line correctly" $ do+        let s = "one\ntwo\n" :: ByteString+            pe = err (posN 4 s) (utok 116 <> etok 120) :: PW+        parseErrorPretty' s pe `shouldBe`+          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"+      it "shows position on 1000 line correctly" $ do+        let s = B.replicate 999 10 <> "abc"+            pe = err (posN 999 s) (utok 97 <> etok 100) :: PW+        parseErrorPretty' s pe `shouldBe`+          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"+   describe "sourcePosStackPretty" $     it "result never ends with a newline " $       property $ \x ->@@ -166,11 +262,16 @@         in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)    describe "parseErrorTextPretty" $ do-    it "shows unknown ParseError correctly" $-      parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n"+    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`)+        parseErrorTextPretty (x :: PE)+          `shouldSatisfy` ("\n" `isSuffixOf`)  #if MIN_VERSION_base(4,8,0)   describe "displayException" $@@ -182,14 +283,8 @@ ---------------------------------------------------------------------------- -- Helpers -checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property-checkMergedItems f e1 e2 = f (e1 <> e2) === r-  where r = case (compare `on` errorPos) e1 e2 of-              LT -> f e2-              EQ -> (E.union `on` f) e1 e2-              GT -> f e1- contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property contains g r e = property (all f (g e))-  where rendered = parseErrorPretty e-        f x = r x `isInfixOf` rendered+  where+    rendered = parseErrorPretty e+    f x = r x `isInfixOf` rendered
tests/Text/Megaparsec/ExprSpec.hs view
@@ -4,16 +4,14 @@  module Text.Megaparsec.ExprSpec (spec) where -import Control.Applicative (some, (<|>)) import Data.Monoid ((<>)) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck+import Text.Megaparsec import Text.Megaparsec.Char-import Text.Megaparsec.Combinator import Text.Megaparsec.Expr-import Text.Megaparsec.Prim  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)@@ -34,9 +32,8 @@     context "when term is missing" $       it "signals correct parse error" $ do         let p = expr <* eof-            n = 1 :: Integer-        prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term")-        prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term")+        prs p "-" `shouldFailWith` err (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" $@@ -109,7 +106,8 @@ arbitraryN0 :: Int -> Gen Node arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)                           , (9, arbitraryN1 n) ]-  where leaf = arbitraryN1 (n `div` 2)+  where+    leaf = arbitraryN1 (n `div` 2)  arbitraryN1 :: Int -> Gen Node arbitraryN1 n =@@ -120,21 +118,22 @@ 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)+  where+    leaf = arbitraryN0 (n `div` 2)  -- Some helpers are put here since we don't want to depend on -- "Text.Megaparsec.Lexer". -lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a+lexeme :: Parser a -> Parser a lexeme p = p <* hidden space -symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String+symbol :: String -> Parser String symbol = lexeme . string -parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a+parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") -integer :: (MonadParsec e s m, Token s ~ Char) => m Integer+integer :: Parser Integer integer = lexeme (read <$> some digitChar <?> "integer")  -- Here we use a table of operators that makes use of all features of@@ -142,18 +141,19 @@ -- but valid expressions and render them to get their textual -- representation. -expr :: (MonadParsec e s m, Token s ~ Char) => m Node+expr :: Parser Node expr = makeExprParser term table -term :: (MonadParsec e s m, Token s ~ Char) => m Node+term :: Parser Node term = parens expr <|> (Val <$> integer) <?> "term" -table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]]-table = [ [ Prefix  (symbol "-" *> pure Neg)-          , Postfix (symbol "!" *> pure Fac)-          , InfixN  (symbol "%" *> pure Mod) ]-        , [ InfixR  (symbol "^" *> pure Exp) ]-        , [ InfixL  (symbol "*" *> pure Pro)-          , InfixL  (symbol "/" *> pure Div) ]-        , [ InfixL  (symbol "+" *> pure Sum)-          , InfixL  (symbol "-" *> pure Sub)] ]+table :: [[Operator Parser Node]]+table =+  [ [ Prefix  (symbol "-" *> pure Neg)+    , Postfix (symbol "!" *> pure Fac)+    , InfixN  (symbol "%" *> pure Mod) ]+  , [ InfixR  (symbol "^" *> pure Exp) ]+  , [ InfixL  (symbol "*" *> pure Pro)+    , InfixL  (symbol "/" *> pure Div) ]+  , [ InfixL  (symbol "+" *> pure Sum)+    , InfixL  (symbol "-" *> pure Sub)] ]
− tests/Text/Megaparsec/LexerSpec.hs 
@@ -1,490 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf       #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE TypeFamilies     #-}--module Text.Megaparsec.LexerSpec (spec) where--import Control.Applicative-import Control.Monad (void)-import Data.Char hiding (ord)-import Data.List (isInfixOf)-import Data.Maybe-import Data.Monoid ((<>))-import Data.Scientific (fromFloatDigits)-import Numeric (showInt, showHex, showOct)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Error-import Text.Megaparsec.Lexer-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String-import qualified Text.Megaparsec.Char as C--spec :: Spec-spec = do--  describe "space" $-    it "consumes any sort of white space" $-      property $ forAll mkWhiteSpace $ \s -> do-        prs  scn s `shouldParse` ()-        prs' scn s `succeedsLeaving` ""--  describe "symbol" $-    context "when stream begins with the symbol" $-      it "parses the symbol and trailing whitespace" $-        property $ forAll mkSymbol $ \s -> do-          let p = symbol scn y-              y = takeWhile (not . isSpace) s-          prs  p s `shouldParse` y-          prs' p s `succeedsLeaving` ""--  describe "symbol'" $-    context "when stream begins with the symbol" $-      it "parses the symbol and trailing whitespace" $-        property $ forAll mkSymbol $ \s -> do-          let p = symbol' scn (toUpper <$> y)-              y = takeWhile (not . isSpace) s-          prs  p s `shouldParse` y-          prs' p s `succeedsLeaving` ""--  describe "skipLineComment" $-    context "when there is no newline at the end of line" $-      it "is picked up successfully" $ do-        let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof-            s = "  // this line comment doesn't have a newline at the end "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""--  describe "skipBlockCommentNested" $-    context "when it runs into nested block comments" $-      it "parses them all right" $ do-        let p = space (void C.spaceChar) empty-              (skipBlockCommentNested "/*" "*/") <* eof-            s = " /* foo bar /* baz */ quux */ "-        prs  p s `shouldParse` ()-        prs' p s `succeedsLeaving` ""--  describe "indentLevel" $-    it "returns current indentation level (column)" $-      property $ \pos -> do-        let p = setPosition pos *> indentLevel-        prs p "" `shouldParse` sourceColumn pos--  describe "incorrectIndent" $-    it "signals correct parse error" $-      property $ \ord ref actual -> do-        let p :: Parser ()-            p = incorrectIndent ord ref actual-        prs p "" `shouldFailWith` err posI (ii ord ref actual)--  describe "indentGuard" $-    it "works as intended" $-      property $ \n -> do-        let mki = mkIndent sbla (getSmall $ getNonNegative n)-        forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do-          let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-              fragments = [l0,l1,l2]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              p  = ip GT pos1 >>=-                \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn-              ip = indentGuard scn-              sp = void (symbol sc sbla <* C.eol)-          if | col0 <= pos1 ->-               prs p s `shouldFailWith` err posI (ii GT pos1 col0)-             | col1 /= col0 ->-               prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)-             | col2 <= col0 ->-               prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)-             | otherwise    ->-               prs p s `shouldParse` ()--  describe "nonIdented" $-    it "works as intended" $-      property $ forAll (mkIndent sbla 0) $ \s -> do-        let p = nonIndented scn (symbol scn sbla)-            i = getIndent s-        if i == 0-          then prs p s `shouldParse` sbla-          else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s))--  describe "indentBlock" $ do-    it "works as indented" $-      property $ \mn'' -> do-        let mkBlock = do-              l0 <- mkIndent sbla 0-              l1 <- mkIndent sblb ib-              l2 <- mkIndent sblc (ib + 2)-              l3 <- mkIndent sblb ib-              l4 <- mkIndent' sblc (ib + 2)-              return (l0,l1,l2,l3,l4)-            ib  = fromMaybe 2 mn'-            mn' = getSmall . getPositive <$> mn''-            mn  = unsafePos . fromIntegral <$> mn'-        forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do-          let (col0, col1, col2, col3, col4) =-                (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)-              fragments = [l0,l1,l2,l3,l4]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              p = lvla <* eof-              lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla-              lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb-              lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc-              b    = symbol sc-              l x  = return . (x,)-              ib'  = unsafePos (fromIntegral ib)-          if | col1 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof)-             | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`-               err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)-             | col2 <= col1 -> prs p s `shouldFailWith`-               err (posN (getIndent l2 + g 2) s) (ii GT col1 col2)-             | col3 == col2 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc <> eeof)-             | col3 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof)-             | col3 < col1 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)-             | col3 > col1 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)-             | col4 <= col3 -> prs p s `shouldFailWith`-               err (posN (getIndent l4 + g 4) s) (ii GT col3 col4)-             | otherwise -> prs p s `shouldParse`-               (sbla, [(sblb, [sblc]), (sblb, [sblc])])-    it "IndentMany works as intended (newline at the end)" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do-        let p    = lvla-            lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  p s `shouldParse` (sbla, [])-        prs' p s `succeedsLeaving` ""-    it "IndentMany works as intended (eof)" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do-        let p    = lvla-            lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  p s `shouldParse` (sbla, [])-        prs' p s `succeedsLeaving` ""-    it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do-      let p    = lvla-          lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-          lvlb = b sblb-          b    = symbol sc-          l x  = return . (x,)-          s    = "aaa\n bbb\n "-      prs  p s `shouldParse` (sbla, [sblb])-      prs' p s `succeedsLeaving` ""-    it "works with many and both IndentMany and IndentNone" $-      property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do-        let p1   = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-            p2   = indentBlock scn $ IndentNone sbla <$ b sbla-            lvlb = b sblb-            b    = symbol sc-            l x  = return . (x,)-        prs  (many p1) s `shouldParse` [(sbla, [])]-        prs  (many p2) s `shouldParse` [sbla]-        prs' (many p1) s `succeedsLeaving` ""-        prs' (many p2) s `succeedsLeaving` ""--  describe "lineFold" $-    it "works as intended" $-      property $ do-        let mkFold = do-              l0 <- mkInterspace sbla 0-              l1 <- mkInterspace sblb 1-              l2 <- mkInterspace sblc 1-              return (l0,l1,l2)-        forAll mkFold $ \(l0,l1,l2) -> do-          let p = lineFold scn $ \sc' -> do-                a <- symbol sc' sbla-                b <- symbol sc' sblb-                c <- symbol scn sblc-                return (a, b, c)-              getEnd x = last x == '\n'-              fragments = [l0,l1,l2]-              g x = sum (length <$> take x fragments)-              s = concat fragments-              (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-              (end0, end1)       = (getEnd l0, getEnd l1)-          if | end0 && col1 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l1 + g 1) s) (ii GT col0 col1)-             | end1 && col2 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)-             | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)--  describe "charLiteral" $ do-    context "when stream begins with a literal character" $-      it "parses it" $-        property $ \ch -> do-          let p = charLiteral-              s = showLitChar ch ""-          prs  p s `shouldParse` ch-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with a literal character" $-      it "signals correct parse error" $ do-        let p = charLiteral-            s = "\\"-        prs  p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character")-        prs' p s `failsLeaving` s-    context "when stream is empty" $-      it "signals correct parse error" $ do-        let p = charLiteral-        prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character")--  describe "integer" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = integer-              n = getNonNegative n'-              s = showInt n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with decimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = integer-              s = a : as-          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs integer "" `shouldFailWith`-          err posI (ueof <> elabel "integer")--  describe "decimal" $ do-    context "when stream begins with decimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = decimal-              n = getNonNegative n'-              s = showInt n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with decimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = decimal-              s = a : as-          prs  p s `shouldFailWith` err posI (utok a <> elabel "decimal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs decimal "" `shouldFailWith`-          err posI (ueof <> elabel "decimal integer")--  describe "hexadecimal" $ do-    context "when stream begins with hexadecimal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = hexadecimal-              n = getNonNegative n'-              s = showHex n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with hexadecimal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isHexDigit a) ==> do-          let p = hexadecimal-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "hexadecimal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs hexadecimal "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")--  describe "octal" $ do-    context "when stream begins with octal digits" $-      it "they are parsed as an integer" $-        property $ \n' -> do-          let p = octal-              n = getNonNegative n'-              s = showOct n ""-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with octal digits" $-      it "signals correct parse error" $-        property $ \a as -> not (isOctDigit a) ==> do-          let p = octal-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "octal integer")-    context "when stream is empty" $-      it "signals correct parse error" $-        prs octal "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")--  describe "float" $ do-    context "when stream begins with a float" $-      it "parses it" $-        property $ \n' -> do-          let p = float-              n = getNonNegative n'-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when stream does not begin with a float" $-      it "signals correct parse error" $-        property $ \a as -> not (isDigit a) ==> do-          let p = float-              s = a : as-          prs  p s `shouldFailWith`-            err posI (utok a <> elabel "floating point number")-          prs' p s `failsLeaving` s-    context "when stream begins with a decimal number" $-      it "signals correct parse error" $-        property $ \n' -> do-          let p = float-              n = getNonNegative n'-              s = show (n :: Integer)-          prs  p s `shouldFailWith` err (posN (length s) s)-            (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")-          prs' p s `failsLeaving` ""-    context "when stream is empty" $-      it "signals correct parse error" $-        prs float "" `shouldFailWith`-          err posI (ueof <> elabel "floating point number")-    context "when there is float with exponent without explicit sign" $-      it "parses it all right" $ do-        let p = float-            s = "123e3"-        prs  p s `shouldParse` 123e3-        prs' p s `succeedsLeaving` ""--  describe "number" $ do-    context "when stream begins with a number" $-      it "parses it" $-        property $ \n' -> do-          let p = number-              s = either (show . getNonNegative) (show . getNonNegative)-                (n' :: Either (NonNegative Integer) (NonNegative Double))-          prs p s `shouldParse` case n' of-            Left  x -> fromIntegral    (getNonNegative x)-            Right x -> fromFloatDigits (getNonNegative x)-          prs' p s `succeedsLeaving` ""-    context "when stream is empty" $-      it "signals correct parse error" $-        prs number "" `shouldFailWith`-          err posI (ueof <> elabel "number")--  describe "signed" $ do-    context "with integer" $-      it "parses signed integers" $-        property $ \n -> do-          let p = signed (hidden C.space) integer-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with float" $-      it "parses signed floats" $-        property $ \n -> do-          let p = signed (hidden C.space) float-              s = show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "with number" $-      it "parses singed numbers" $-        property $ \n -> do-          let p = signed (hidden C.space) number-              s = either show show (n :: Either Integer Double)-          prs p s `shouldParse` case n of-            Left  x -> fromIntegral    x-            Right x -> fromFloatDigits x-    context "when number is prefixed with plus sign" $-      it "parses the number" $-        property $ \n' -> do-          let p = signed (hidden C.space) integer-              n = getNonNegative n'-              s = '+' : show n-          prs  p s `shouldParse` n-          prs' p s `succeedsLeaving` ""-    context "when number is prefixed with white space" $-      it "signals correct parse error" $-        property $ \n -> do-          let p = signed (hidden C.space) integer-              s = ' ' : show (n :: Integer)-          prs  p s `shouldFailWith` err posI-            (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")-          prs' p s `failsLeaving` s-    context "when there is white space between sign and digits" $-      it "parses it all right" $ do-        let p = signed (hidden C.space) integer-            s = "- 123"-        prs  p s `shouldParse` (-123)-        prs' p s `succeedsLeaving` ""--------------------------------------------------------------------------------- Helpers--mkWhiteSpace :: Gen String-mkWhiteSpace = concat <$> listOf whiteUnit-  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]--mkWhiteSpaceNl :: Gen String-mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n"--mkSymbol :: Gen String-mkSymbol = (++) <$> symbolName <*> whiteChars--mkInterspace :: String -> Int -> Gen String-mkInterspace x n = oneof [si, mkIndent x n]-  where si = (++ x) <$> listOf (elements " \t")--mkIndent :: String -> Int -> Gen String-mkIndent x n = (++) <$> mkIndent' x n <*> eol-  where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]--mkIndent' :: String -> Int -> Gen String-mkIndent' x n = concat <$> sequence [spc, sym, tra]-  where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]-        tra = listOf itm-        itm = elements " \t"-        sym = return x--whiteChars :: Gen String-whiteChars = listOf (elements "\t\n ")--whiteLine :: Gen String-whiteLine = commentOut <$> arbitrary `suchThat` goodEnough-  where commentOut x = "//" ++ x ++ "\n"-        goodEnough x = '\n' `notElem` x--whiteBlock :: Gen String-whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough-  where commentOut x = "/*" ++ x ++ "*/"-        goodEnough x = not $ "*/" `isInfixOf` x--symbolName :: Gen String-symbolName = listOf $ arbitrary `suchThat` isAlphaNum--sc :: Parser ()-sc = space (void $ C.oneOf " \t") empty empty--scn :: Parser ()-scn = space (void C.spaceChar) l b-  where l = skipLineComment "//"-        b = skipBlockComment "/*" "*/"--getIndent :: String -> Int-getIndent = length . takeWhile isSpace--getCol :: String -> Pos-getCol x = sourceColumn .-  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x--sbla, sblb, sblc :: String-sbla = "aaa"-sblb = "bbb"-sblc = "ccc"--ii :: Ordering -> Pos -> Pos -> EC Char Dec-ii ord ref actual = cstm (DecIndentation ord ref actual)
tests/Text/Megaparsec/PermSpec.hs view
@@ -10,7 +10,7 @@ import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Char-import Text.Megaparsec.Lexer (integer)+import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Perm  data CharRows = CharRows@@ -42,7 +42,7 @@           prs p "" `shouldParse` succ n     context "when supplied parser fails" $       it "signals correct parse error" $ do-          let p = makePermParser (succ <$$> integer)+          let p = makePermParser (succ <$$> decimal) :: Parser Integer           prs p "" `shouldFailWith` err posI (ueof <> elabel "integer")    describe "(<$?>)" $ do@@ -59,7 +59,7 @@     context "when stream in empty" $       it "returns the default value" $         property $ \n -> do-          let p = makePermParser (succ <$?> (n :: Integer, integer))+          let p = makePermParser (succ <$?> (n :: Integer, decimal))           prs p "" `shouldParse` succ n    describe "makeExprParser" $
tests/Text/Megaparsec/PosSpec.hs view
@@ -1,37 +1,26 @@-{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}- 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.Hspec.Megaparsec.AdHoc () import Test.QuickCheck import Text.Megaparsec.Pos -#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif- spec :: Spec spec = do    describe "mkPos" $ do-    context "when the argument is 0" $+    context "when the argument is a non-positive number" $       it "throws InvalidPosException" $-        mkPos (0 :: Word) `shouldThrow` (== 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) ==> (mkPos n >>= shouldBe n . unPos)--  describe "unsafePos" $-    context "when the argument is a positive integer" $-      it "returns Pos with the given value" $-        property $ \n ->-          (n > 0) ==> (unPos (unsafePos n) === n)+          (n > 0) ==> (unPos (mkPos n) `shouldBe` n)    describe "Read and Show instances of Pos" $     it "printed representation of Pos is isomorphic to its value" $@@ -46,16 +35,16 @@   describe "Semigroup instance of Pos" $     it "works like addition" $       property $ \x y ->-        x <> y === unsafePos (unPos x + unPos y) .&&.+        x <> y === mkPos (unPos x + unPos y) .&&.         unPos (x <> y) === unPos x + unPos y    describe "initialPos" $-    it "consturcts initial position correctly" $+    it "constructs initial position correctly" $       property $ \path ->         let x = initialPos path-        in sourceName   x === path        .&&.-           sourceLine   x === unsafePos 1 .&&.-           sourceColumn x === unsafePos 1+        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" $@@ -72,28 +61,3 @@     it "displays column number" $       property $ \x ->         (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x--  describe "defaultUpdatePos" $ do-    it "returns actual position unchanged" $-      property $ \w pos ch ->-        fst (defaultUpdatePos w pos ch) === pos-    it "does not change file name" $-      property $ \w pos ch ->-        (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos-    context "when given newline character" $-      it "increments line number" $-        property $ \w pos ->-          (sourceLine . snd) (defaultUpdatePos w pos '\n')-            === (sourceLine pos <> pos1)-    context "when given tab character" $-      it "shits column number to next tab position" $-        property $ \w pos ->-          let c  = sourceColumn pos-              c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t')-          in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0)-    context "when given character other than newline or tab" $-      it "increments column number by one" $-        property $ \w pos ch ->-          (ch /= '\n' && ch /= '\t') ==>-          (sourceColumn . snd) (defaultUpdatePos w pos ch)-            === (sourceColumn pos <> pos1)
− tests/Text/Megaparsec/PrimSpec.hs 
@@ -1,1535 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Text.Megaparsec.PrimSpec (spec) where--import Control.Applicative-import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (toUpper, chr)-import Data.Foldable (asum, concat)-import Data.Function (on)-import Data.List (isPrefixOf, foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, listToMaybe, isJust)-import Data.Monoid-import Data.Proxy-import Data.Word (Word8)-import Prelude hiding (span, concat)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck hiding (label)-import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String-import qualified Control.Monad.RWS.Lazy      as L-import qualified Control.Monad.RWS.Strict    as S-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.ByteString.Char8       as B-import qualified Data.ByteString.Lazy.Char8  as BL-import qualified Data.List.NonEmpty          as NE-import qualified Data.Semigroup              as G-import qualified Data.Set                    as E-import qualified Data.Text                   as T-import qualified Data.Text.Lazy              as TL--#if !MIN_VERSION_QuickCheck(2,8,2)-instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where-  arbitrary = E.fromList <$> arbitrary-  shrink    = fmap E.fromList . shrink . E.toList-#endif--spec :: Spec-spec = do--  describe "non-String instances of Stream" $ do-    context "lazy ByteString" $ do-      it "unconses correctly" $-        property $ \ch' n -> do-          let p  = many (char ch) :: Parsec Dec BL.ByteString String-              s  = replicate (getNonNegative n) ch-              ch = byteToChar ch'-          parse p "" (BL.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "strict ByteString" $ do-      it "unconses correctly" $-        property $ \ch' n -> do-          let p  = many (char ch) :: Parsec Dec B.ByteString String-              s  = replicate (getNonNegative n) ch-              ch = byteToChar ch'-          parse p "" (B.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "lazy Text" $ do-      it "unconses correctly" $-        property $ \ch n -> do-          let p = many (char ch) :: Parsec Dec TL.Text String-              s = replicate (getNonNegative n) ch-          parse p "" (TL.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch-    context "strict Text" $ do-      it "unconses correctly" $-        property $ \ch n -> do-          let p = many (char ch) :: Parsec Dec T.Text String-              s = replicate (getNonNegative n) ch-          parse p "" (T.pack s) `shouldParse` s-      it "updates position like with String" $-        property $ \w pos ch ->-          updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe`-          updatePos (Proxy :: Proxy String) w pos ch--  describe "position in custom stream" $ do--    describe "eof" $-      it "updates position in stream correctly" $-        property $ \st -> (not . null . stateInput) st ==> do-          let p = eof :: CustomParser ()-              h = head (stateInput st)-              apos = let (_:|z) = statePos st in spanStart h :| z-          runParser' p st `shouldBe`-            ( st { statePos = apos }-            , Left (err apos $ utok h <> eeof) )--    describe "token" $ do-      context "when input stream is empty" $-        it "signals correct parse error" $-          property $ \st'@State {..} span -> do-            let p = pSpan span-                st = (st' :: State [Span]) { stateInput = [] }-            runParser' p st `shouldBe`-              ( st-              , Left (err statePos $ ueof <> etok span) )-      context "when head of stream matches" $-        it "updates parser state correctly" $-          property $ \st'@State {..} span -> do-            let p = pSpan span-                st = st' { stateInput = span : stateInput }-                npos = spanEnd span :| NE.tail statePos-            runParser' p st `shouldBe`-              ( st { statePos             = npos-                   , stateTokensProcessed = stateTokensProcessed + 1-                   , stateInput           = stateInput }-              , Right span )-      context "when head of stream does not match" $ do-        let checkIt s span =-              let ms = listToMaybe s-              in isJust ms && (spanBody <$> ms) /= Just (spanBody span)-        it "signals correct parse error" $-          property $ \st@State {..} span -> checkIt stateInput span ==> do-            let p = pSpan span-                h = head stateInput-                apos = spanStart h :| NE.tail statePos-            runParser' p st `shouldBe`-              ( st { statePos = apos }-              , Left (err apos $ utok h <> etok span))--    describe "tokens" $-      it "updates position is stream correctly" $-        property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do-          let p = tokens compareTokens ts :: CustomParser [Span]-              compareTokens x y = spanBody x == spanBody y-              updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth-              il = length . takeWhile id $ zipWith compareTokens stateInput ts-              tl = length ts-              consumed = take il stateInput-              (apos, npos) =-                let (pos:|z) = statePos-                in ( spanStart (head stateInput) :| z-                   , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z )-          if | null ts -> runParser' p st `shouldBe` (st, Right [])-             | null stateInput -> runParser' p st `shouldBe`-               ( st-               , Left (err statePos $ ueof <> etoks ts) )-             | il == tl -> runParser' p st `shouldBe`-               ( st { statePos             = npos-                    , stateTokensProcessed = stateTokensProcessed + fromIntegral tl-                    , stateInput           = drop (length ts) stateInput }-               , Right consumed )-             | otherwise -> runParser' p st `shouldBe`-               ( st { statePos = apos }-               , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) )--    describe "getNextTokenPosition" $ do-      context "when input stream is empty" $-        it "returns Nothing" $-          property $ \st' -> do-            let p :: CustomParser (Maybe SourcePos)-                p = getNextTokenPosition-                st = (st' :: State [Span]) { stateInput = [] }-            runParser' p st `shouldBe` (st, Right Nothing)-      context "when input stream is not empty" $-        it "return the position of start of the next token" $-           property $ \st' h -> do-             let p :: CustomParser (Maybe SourcePos)-                 p = getNextTokenPosition-                 st = st' { stateInput = h : stateInput st' }-             runParser' p st `shouldBe` (st, (Right . Just . spanStart) h)--  describe "ParsecT Semigroup instance" $-    it "the associative operation works" $-      property $ \a b -> do-        let p = pure [a] G.<> pure [b]-        prs p "" `shouldParse` ([a,b] :: [Int])--  describe "ParsecT Monoid instance" $ do-    it "mempty works" $ do-      let p = mempty-      prs p "" `shouldParse` ([] :: [Int])-    it "mappend works" $-      property $ \a b -> do-        let p = pure [a] `mappend` pure [b]-        prs p "" `shouldParse` ([a,b] :: [Int])--  describe "ParsecT Functor instance" $ do-    it "obeys identity law" $-      property $ \n ->-        prs (fmap id (pure (n :: Int))) "" ===-        prs (id (pure n))               ""-    it "obeys composition law" $-      property $ \n m t ->-        let f = (+ m)-            g = (* t)-        in prs (fmap (f . g) (pure (n :: Int))) "" ===-           prs ((fmap f . fmap g) (pure n))     ""--  describe "ParsecT Applicative instance" $ do-    it "obeys identity law" $-      property $ \n ->-        prs (pure id <*> pure (n :: Int)) "" ===-        prs (pure n) ""-    it "obeys composition law" $-      property $ \n m t ->-        let u = pure (+ m)-            v = pure (* t)-            w = pure (n :: Int)-        in prs (pure (.) <*> u <*> v <*> w) "" ===-           prs (u <*> (v <*> w)) ""-    it "obeys homomorphism law" $-      property $ \x m ->-        let f = (+ m)-        in prs (pure f <*> pure (x :: Int)) "" ===-           prs (pure (f x)) ""-    it "obeys interchange law" $-      property $ \n y ->-        let u = pure (+ n)-        in prs (u <*> pure (y :: Int)) "" ===-           prs (pure ($ y) <*> u) ""-    describe "(<*>)" $-      context "when first parser succeeds without consuming" $-        context "when second parser fails consuming input" $-          it "fails consuming input" $ do-            let p = m <*> n-                m = return (\x -> 'a' : x)-                n = string "bc" <* empty-                s = "bc"-            prs  p s `shouldFailWith` err (posN (4 :: Int) s) mempty-            prs' p s `failsLeaving`   ""-    describe "(*>)" $-      it "works correctly" $-        property $ \n m ->-          let u = pure (+ (m :: Int))-              v = pure (n :: Int)-          in prs (u *> v) "" ===-             prs (pure (const id) <*> u <*> v) ""-    describe "(<*)" $-      it "works correctly" $-        property $ \n m ->-          let u = pure (m :: Int)-              v = pure (+ (n :: Int))-          in prs (u <* v) "" === prs (pure const <*> u <*> v) ""--  describe "ParsecT Alternative instance" $ do--    describe "empty" $-      it "always fails" $-        property $ \n ->-          prs (empty <|> pure n) "" `shouldParse` (n :: Integer)--    describe "(<|>)" $ do-      context "with two strings" $ do-        context "stream begins with the first string" $-          it "parses the string" $-            property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do-              let s' = s0 ++ s-                  p = string s0 <|> string s1-              prs  p s' `shouldParse` s0-              prs' p s' `succeedsLeaving` s-        context "stream begins with the second string" $-          it "parses the string" $-            property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do-              let s' = s1 ++ s-                  p = string s0 <|> string s1-              prs  p s' `shouldParse` s1-              prs' p s' `succeedsLeaving` s-        context "when stream does not begin with either string" $-          it "signals correct error message" $-            property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do-              let p = string s0 <|> string s1-                  z0' = toFirstMismatch (==) s0 s-                  z1' = toFirstMismatch (==) s1 s-              prs  p s `shouldFailWith` err posI-                (etoks s0 <>-                 etoks s1 <>-                 (if null s then ueof else mempty) <>-                 (if null z0' then mempty else utoks z0') <>-                 (if null z1' then mempty else utoks z1'))-      context "with two complex parsers" $ do-        context "when stream begins with matching character" $-          it "parses it" $-            property $ \a b -> a /= b ==> do-              let p = char a <|> (char b *> char a)-                  s = [a]-              prs  p s `shouldParse` a-              prs' p s `succeedsLeaving` ""-        context "when stream begins with only one matching character" $-          it "signals correct parse error" $-            property $ \a b c -> a /= b && a /= c ==> do-              let p = char a <|> (char b *> char a)-                  s = [b,c]-              prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a)-              prs' p s `failsLeaving` [c]-        context "when stream begins with not matching character" $-          it "signals correct parse error" $-            property $ \a b c -> a /= b && a /= c && b /= c ==> do-              let p = char a <|> (char b *> char a)-                  s = [c,b]-              prs  p s `shouldFailWith` err posI (utok c <> etok a <> etok b)-              prs' p s `failsLeaving` s-        context "when stream is emtpy" $-          it "signals correct parse error" $-            property $ \a b -> do-              let p = char a <|> (char b *> char a)-              prs  p "" `shouldFailWith` err posI (ueof <> etok a <> etok b)-      it "associativity of fold over alternatives should not matter" $ do-        let p  = asum [empty, string ">>>", empty, return "foo"] <?> "bar"-            p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"-            bsum = foldl (<|>) empty-            s  = ">>"-        prs p s `shouldBe` prs p' s--    describe "many" $ do-      context "when stream begins with things argument of many parses" $-        it "they are parsed" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = many (char 'a')-                s = abcRow a b c-            prs  p s `shouldParse` replicate a 'a'-            prs' p s `succeedsLeaving` drop a s-      context "when stream does not begin with thing argument of many parses" $-        it "does nothing" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = many (char 'd')-                s = abcRow a b c-            prs  p s `shouldParse` ""-            prs' p s `succeedsLeaving` s-      context "when stream is empty" $-        it "succeeds parsing nothing" $ do-          let p = many (char 'a')-          prs  p "" `shouldParse` ""-      context "when there are two many combinators in a row that parse nothing" $-        it "accumulated hints are reflected in parse error" $ do-          let p = many (char 'a') *> many (char 'b') *> eof-          prs p "c" `shouldFailWith` err posI-            (utok 'c' <> etok 'a' <> etok 'b' <> eeof)-      context "when the argument parser succeeds without consuming" $-        it "is run nevertheless" $-          property $ \n' -> do-            let n = getSmall (getNonNegative n') :: Integer-                p = void . many $ do-                  x <- S.get-                  if x < n then S.modify (+ 1) else empty-                v :: S.State Integer (Either (ParseError Char Dec) ())-                v = runParserT p "" ""-            S.execState v 0 `shouldBe` n--    describe "some" $ do-      context "when stream begins with things argument of some parses" $-        it "they are parsed" $-          property $ \a' b' c' -> do-            let a = getPositive a'-                [b,c] = getNonNegative <$> [b',c']-                p = some (char 'a')-                s = abcRow a b c-            prs  p s `shouldParse` replicate a 'a'-            prs' p s `succeedsLeaving` drop a s-      context "when stream does not begin with thing argument of some parses" $-        it "signals correct parse error" $-          property $ \a' b' c' -> do-            let [a,b,c] = getNonNegative <$> [a',b',c']-                p = some (char 'd')-                s = abcRow a b c ++ "g"-            prs  p s `shouldFailWith` err posI (utok (head s) <> etok 'd')-            prs' p s `failsLeaving` s-      context "when stream is empty" $-        it "signals correct parse error" $-          property $ \ch -> do-            let p = some (char ch)-            prs  p "" `shouldFailWith` err posI (ueof <> etok ch)-    context "optional" $ do-      context "when stream begins with that optional thing" $-        it "parses it" $-          property $ \a b -> do-            let p = optional (char a) <* char b-                s = [a,b]-            prs  p s `shouldParse` Just a-            prs' p s `succeedsLeaving` ""-      context "when stream does not begin with that optional thing" $-        it "succeeds parsing nothing" $-          property $ \a b -> a /= b ==> do-            let p = optional (char a) <* char b-                s = [b]-            prs  p s `shouldParse` Nothing-            prs' p s `succeedsLeaving` ""-      context "when stream is empty" $-        it "succeeds parsing nothing" $-          property $ \a -> do-            let p = optional (char a)-            prs  p "" `shouldParse` Nothing--  describe "ParsecT Monad instance" $ do-    it "satisfies left identity law" $-      property $ \a k' -> do-        let k = return . (+ k')-            p = return (a :: Int) >>= k-        prs p "" `shouldBe` prs (k a) ""-    it "satisfies right identity law" $-      property $ \a -> do-        let m = return (a :: Int)-            p = m >>= return-        prs p "" `shouldBe` prs m ""-    it "satisfies associativity law" $-      property $ \m' k' h' -> do-        let m = return (m' :: Int)-            k = return . (+ k')-            h = return . (* h')-            p = m >>= (\x -> k x >>= h)-            p' = (m >>= k) >>= h-        prs p "" `shouldBe` prs p' ""-    it "fails signals correct parse error" $-      property $ \msg -> do-        let p = fail msg :: Parsec Dec String ()-        prs p "" `shouldFailWith` err posI (cstm (DecFail msg))-    it "pure is the same as return" $-      property $ \n ->-        prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""-    it "(<*>) is the same as ap" $-      property $ \m' k' -> do-        let m = return (m' :: Int)-            k = return (+ k')-        prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""--  describe "ParsecT MonadFail instance" $-    describe "fail" $-      it "signals correct parse error" $-        property $ \s msg -> do-          let p = void (fail msg)-          prs  p s `shouldFailWith` err posI (cstm $ DecFail msg)-          prs' p s `failsLeaving` s--  describe "ParsecT MonadIO instance" $-    it "liftIO works" $-      property $ \n -> do-        let p = liftIO (return n) :: ParsecT Dec String IO Integer-        runParserT p "" "" `shouldReturn` Right n--  describe "ParsecT MonadReader instance" $ do--    describe "ask" $-      it "returns correct value of context" $-        property $ \n -> do-          let p = ask :: ParsecT Dec String (Reader Integer) Integer-          runReader (runParserT p "" "") n `shouldBe` Right n--    describe "local" $-      it "modifies reader context correctly" $-        property $ \n k -> do-          let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer-          runReader (runParserT p "" "") n `shouldBe` Right (n + k)--  describe "ParsecT MonadState instance" $ do--    describe "get" $-      it "returns correct state value" $-        property $ \n -> do-          let p = L.get :: ParsecT Dec String (L.State Integer) Integer-          L.evalState (runParserT p "" "") n `shouldBe` Right n-    describe "put" $-      it "replaces state value" $-        property $ \a b -> do-          let p = L.put b :: ParsecT Dec String (L.State Integer) ()-          L.execState (runParserT p "" "") a `shouldBe` b--  describe "ParsecT MonadCont instance" $--    describe "callCC" $-      it "works properly" $-        property $ \a b -> do-          let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer-              p = callCC $ \e -> when (a > b) (e a) >> return b-          runCont (runParserT p "" "") id `shouldBe` Right (max a b)--  describe "ParsecT MonadError instance" $ do--    describe "throwError" $-      it "throws the error" $-        property $ \a b -> do-          let p :: ParsecT Dec String (Except Integer) Integer-              p = throwError a >> return b-          runExcept (runParserT p "" "") `shouldBe` Left a--    describe "catchError" $-      it "catches the error" $-        property $ \a b -> do-          let p :: ParsecT Dec String (Except Integer) Integer-              p = (throwError a >> return b) `catchError` handler-              handler e = return (e + b)-          runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)--  describe "primitive combinators" $ do--    describe "unexpected" $-      it "signals correct parse error" $-        property $ \item -> do-          let p :: MonadParsec Dec String m => m ()-              p = void (unexpected item)-          grs p "" (`shouldFailWith` ParseError-            { errorPos        = posI-            , errorUnexpected = E.singleton item-            , errorExpected   = E.empty-            , errorCustom     = E.empty })--    describe "match" $-      it "return consumed tokens along with the result" $-        property $ \str -> do-          let p  = match (string str)-          prs  p str `shouldParse`     (str,str)-          prs' p str `succeedsLeaving` ""--    describe "region" $ do-      context "when inner parser succeeds" $-        it "has no effect" $-          property $ \st e n -> do-            let p :: Parser Int-                p = region (const e) (pure n)-            runParser' p st `shouldBe` (st, Right (n :: Int))-      context "when inner parser fails" $-        it "the given function is used on the parse error" $-          property $ \st e0 e1 -> do-            let p :: Parser Int-                p = region f $ failure-                  (errorUnexpected e0)-                  (errorExpected   e0)-                  (errorCustom     e0)-                f x = ParseError-                  { errorPos        = ((G.<>)  `on` errorPos)        x e1-                  , errorUnexpected = (E.union `on` errorUnexpected) x e1-                  , errorExpected   = (E.union `on` errorExpected)   x e1-                  , errorCustom     = (E.union `on` errorCustom)     x e1 }-                r = ParseError-                  { errorPos        = finalPos-                  , errorUnexpected = (E.union `on` errorUnexpected) e0 e1-                  , errorExpected   = (E.union `on` errorExpected)   e0 e1-                  , errorCustom     = (E.union `on` errorCustom)     e0 e1 }-                finalPos = statePos st G.<> errorPos e1-            runParser' p st `shouldBe` (st { statePos = finalPos }, Left r)--    describe "failure" $-      it "signals correct parse error" $-        property $ \us ps xs -> do-          let p :: MonadParsec Dec String m => m ()-              p = void (failure us ps xs)-          grs p "" (`shouldFailWith` ParseError-            { errorPos        = posI-            , errorUnexpected = us-            , errorExpected   = ps-            , errorCustom     = xs })--    describe "label" $ do-      context "when inner parser succeeds consuming input" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Dec String m => m Char-                  p = label lbl (char a) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-        context "inner parser produces hints" $-          it "replaces the last hint with “the rest of <label>”" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Dec String m => m String-                  p = label lbl (many (char a)) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (elabel $ "the rest of " ++ lbl))-              grs' p s (`failsLeaving` "")-      context "when inner parser consumes and fails" $-        it "reports parse error without modification" $-          property $ \lbl a b c -> not (null lbl) && b /= c ==> do-            let p :: MonadParsec Dec String m => m Char-                p = label lbl (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Dec String m => m Char-                  p = label lbl (return a) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-        context "inner parser produces hints" $-          it "replaces the last hint with given label" $-            property $ \lbl a -> not (null lbl) ==> do-              let p :: MonadParsec Dec String m => m String-                  p = label lbl (many (char a)) <* empty-              grs p "" (`shouldFailWith` err posI (elabel lbl))-      context "when inner parser fails without consuming" $-        it "is mentioned in parse error via its label" $-          property $ \lbl -> not (null lbl) ==> do-            let p :: MonadParsec Dec String m => m ()-                p = label lbl empty-            grs p "" (`shouldFailWith` err posI (elabel lbl))--    describe "hidden" $ do-      context "when inner parser succeeds consuming input" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \a -> do-              let p :: MonadParsec Dec String m => m Char-                  p = hidden (char a) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-        context "inner parser produces hints" $-          it "hides the parser in the error message" $-            property $ \a -> do-              let p :: MonadParsec Dec String m => m String-                  p = hidden (many (char a)) <* empty-                  s = [a]-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-              grs' p s (`failsLeaving` "")-      context "when inner parser consumes and fails" $-        it "reports parse error without modification" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Dec String m => m Char-                p = hidden (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        context "inner parser does not produce any hints" $-          it "collection of hints remains empty" $-            property $ \a -> do-              let p :: MonadParsec Dec String m => m Char-                  p = hidden (return a) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-        context "inner parser produces hints" $-          it "hides the parser in the error message" $-            property $ \a -> do-              let p :: MonadParsec Dec String m => m String-                  p = hidden (many (char a)) <* empty-              grs p "" (`shouldFailWith` err posI mempty)-      context "when inner parser fails without consuming" $-        it "hides the parser in the error message" $ do-          let p :: MonadParsec Dec String m => m ()-              p = hidden empty-          grs p "" (`shouldFailWith` err posI mempty)--    describe "try" $ do-      context "when inner parser succeeds consuming" $-        it "try has no effect" $-          property $ \a -> do-            let p :: MonadParsec Dec String m => m Char-                p = try (char a)-                s = [a]-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` "")-      context "when inner parser fails consuming" $-        it "backtracks, it appears as if the parser has not consumed anything" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Dec String m => m Char-                p = try (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` s)-      context "when inner parser succeeds without consuming" $-        it "try has no effect" $-          property $ \a -> do-            let p :: MonadParsec Dec String m => m Char-                p = try (return a)-            grs p "" (`shouldParse` a)-      context "when inner parser fails without consuming" $-        it "try backtracks parser state anyway" $-          property $ \w -> do-            let p :: MonadParsec Dec String m => m Char-                p = try (setTabWidth w *> empty)-            grs  p "" (`shouldFailWith` err posI mempty)-            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)--    describe "lookAhead" $ do-      context "when inner parser succeeds consuming" $ do-        it "result is returned but parser state is not changed" $-          property $ \a w -> do-            let p :: MonadParsec Dec String m => m Pos-                p = lookAhead (setTabWidth w *> char a) *> getTabWidth-                s = [a]-            grs  p s (`shouldParse` defaultTabWidth)-            grs' p s (`succeedsLeaving` s)-        it "hints are not preserved" $-          property $ \a -> do-            let p :: MonadParsec Dec String m => m String-                p = lookAhead (many (char a)) <* empty-                s = [a]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser fails consuming" $-        it "error message is reported as usual" $-          property $ \a b c -> b /= c ==> do-            let p :: MonadParsec Dec String m => m Char-                p = lookAhead (char a *> char b)-                s = [a,c]-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-            grs' p s (`failsLeaving` [c])-      context "when inner parser succeeds without consuming" $ do-        it "result is returned but parser state in not changed" $-          property $ \a w -> do-            let p :: MonadParsec Dec String m => m Pos-                p = lookAhead (setTabWidth w *> char a) *> getTabWidth-                s = [a]-            grs  p s (`shouldParse` defaultTabWidth)-            grs' p s (`succeedsLeaving` s)-        it "hints are not preserved" $-          property $ \a b -> a /= b ==> do-            let p :: MonadParsec Dec String m => m String-                p = lookAhead (many (char a)) <* empty-                s = [b]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser fails without consuming" $-        it "error message is reported as usual" $ do-          let p :: MonadParsec Dec String m => m Char-              p = lookAhead empty-          grs p "" (`shouldFailWith` err posI mempty)--    describe "notFollowedBy" $ do-      context "when inner parser succeeds consuming" $-        it "signals correct parse error" $-          property $ \a w -> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (setTabWidth w <* char a)-                s = [a]-            grs  p s (`shouldFailWith` err posI (utok a))-            grs' p s (`failsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-      context "when inner parser fails consuming" $ do-        it "succeeds without consuming" $-          property $ \a b c w -> b /= c ==> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (setTabWidth w *> char a *> char b)-                s = [a,c]-            grs' p s (`succeedsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-        it "hints are not preserved" $-          property $ \a b -> a /= b ==> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (char b *> many (char a) <* char a) <* empty-                s = [b,b]-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)-      context "when inner parser succeeds without consuming" $-        it "signals correct parse error" $-          property $ \a w -> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (setTabWidth w *> return a)-                s = [a]-            grs  p s (`shouldFailWith` err posI (utok a))-            grs' p s (`failsLeaving` s)-            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-      context "when inner parser fails without consuming" $ do-        it "succeeds without consuming" $-          property $ \w -> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (setTabWidth w *> empty)-            grs  p "" (`shouldParse` ())-            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)-        it "hints are not preserved" $-          property $ \a -> do-            let p :: MonadParsec Dec String m => m ()-                p = notFollowedBy (many (char a) <* char a) <* empty-                s = ""-            grs  p s (`shouldFailWith` err posI mempty)-            grs' p s (`failsLeaving` s)--    describe "withRecovery" $ do-      context "when inner parser succeeds consuming" $-        it "the result is returned as usual" $-          property $ \a as -> do-            let p :: MonadParsec Dec String m => m (Maybe Char)-                p = withRecovery (const $ return Nothing) (pure <$> char a)-                s = a : as-            grs  p s (`shouldParse` Just a)-            grs' p s (`succeedsLeaving` as)-      context "when inner parser fails consuming" $ do-        context "when recovering parser succeeds consuming input" $ do-          it "its result is returned and position is advanced" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ string (c : as))-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-              grs' p s (`succeedsLeaving` "")-          it "hints are not preserved" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ string (c : as))-                        (Right <$> char a <* many (char b) <* char b) <* empty-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (length s) s) mempty)-              grs' p s (`failsLeaving` "")-        context "when recovering parser fails consuming input" $-          it "the original parse error (and state) is reported" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ char c <* empty)-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-              grs' p s (`failsLeaving` (c : as))-        context "when recovering parser succeeds without consuming" $ do-          it "its result is returned (and state)" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (return . Left) (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-              grs' p s (`succeedsLeaving` (c : as))-          it "original hints are preserved" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (return . Left)-                        (Right <$> char a <* many (char b) <* char b) <* empty-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (etok b))-              grs' p s (`failsLeaving` (c:as))-        context "when recovering parser fails without consuming" $-          it "the original parse error (and state) is reported" $-            property $ \a b c as -> b /= c ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ empty)-                        (Right <$> char a <* char b)-                  s = a : c : as-              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))-              grs' p s (`failsLeaving` (c : as))-      context "when inner parser succeeds without consuming" $-        it "the result is returned as usual" $-          property $ \a s -> do-            let p :: MonadParsec Dec String m => m (Maybe Char)-                p = withRecovery (const $ return Nothing) (return a)-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` s)-      context "when inner parser fails without consuming" $ do-        context "when recovering parser succeeds consuming input" $-          it "its result is returned and position is advanced" $-            property $ \a as -> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ string s) empty-                  s = a : as-              grs  p s (`shouldParse` Left (err posI mempty))-              grs' p s (`succeedsLeaving` "")-        context "when recovering parser fails consuming input" $-          it "the original parse error (and state) is reported" $-            property $ \a b as -> a /= b ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ char a <* char b <* empty)-                        (Right <$> empty)-                  s = a : as-              grs  p s (`shouldFailWith` err posI mempty)-              grs' p s (`failsLeaving` s)-        context "when recovering parser succeeds without consuming" $ do-          it "its result is returned (and state)" $-            property $ \s -> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (return . Left) empty-              grs  p s (`shouldParse` Left (err posI mempty))-              grs' p s (`succeedsLeaving` s)-          it "original hints are preserved" $-            property $ \a b as -> a /= b ==> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) String)-                  p = withRecovery (return . Left)-                        (Right <$> many (char a) <* empty) <* empty-                  s = b : as-              grs  p s (`shouldFailWith` err posI (etok a))-              grs' p s (`failsLeaving` s)-        context "when recovering parser fails without consuming" $-          it "the original parse error (and state) is reported" $-            property $ \s -> do-              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                  p = withRecovery (\e -> Left e <$ empty) empty-              grs  p s (`shouldFailWith` err posI mempty)-              grs' p s (`failsLeaving` s)-      it "works in complex situations too" $-        property $ \a' b' c' -> do-          let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) String)-              p = let g = count' 1 3 . char in v <$>-                withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'-              v (Right x) y = Right (x ++ y)-              v (Left  m) _ = Left m-              ma = if a < 3 then etok 'a' else mempty-              s = abcRow a b c-              [a,b,c] = getNonNegative <$> [a',b',c']-              f = flip shouldFailWith-              z = flip shouldParse-              r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))-                | a == 0 && b == 0 && c >  3 = f (err posI (utok 'c' <> etok 'a'))-                | a == 0 && b == 0           = f (err posI (utok 'c' <> etok 'a'))-                | a == 0 && b >  3           = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'a' <> etok 'c'))-                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'a' <> etok 'c'))-                | a == 0 &&           c >  3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))-                | a == 0                     = z (Left (err posI (utok 'b' <> etok 'a')))-                | a >  3                     = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))-                |           b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))-                |           b == 0 && c >  3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))-                |           b == 0           = z (Right s)-                | otherwise                  = f (err (posN a s) (utok 'b' <> etok 'c' <> ma))-          grs (p <* eof) s r--    describe "observing" $ do-      context "when inner parser succeeds consuming" $-        it "returns its result in Right" $-          property $ \a as -> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                p = observing (char a)-                s = a : as-            grs  p s (`shouldParse` Right a)-            grs' p s (`succeedsLeaving` as)-      context "when inner parser fails consuming" $ do-        it "returns its parse error in Left preserving state" $-          property $ \a b c as -> b /= c ==> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                p = observing (char a *> char b)-                s = a : c : as-            grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))-            grs' p s (`succeedsLeaving` (c:as))-        it "does not create any hints" $-          property $ \a b c as -> b /= c ==> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                p = observing (char a *> char b) *> empty-                s = a : c : as-            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)-            grs' p s (`failsLeaving` (c:as))-      context "when inner parser succeeds without consuming" $-        it "returns its result in Right" $-          property $ \a s -> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                p = observing (return a)-            grs  p s (`shouldParse` Right a)-            grs' p s (`succeedsLeaving` s)-      context "when inner parser fails without consuming" $ do-        it "returns its parse error in Left preserving state" $-          property $ \s -> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) ())-                p = observing empty-            grs  p s (`shouldParse` Left (err posI mempty))-            grs' p s (`succeedsLeaving` s)-        it "creates correct hints" $-          property $ \a b as -> a /= b ==> do-            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)-                p = observing (char a) <* empty-                s = b : as-            grs  p s (`shouldFailWith` err posI (etok a))-            grs' p s (`failsLeaving` (b:as))--    describe "eof" $ do-      context "when input stream is empty" $-        it "succeeds" $-          grs eof "" (`shouldParse` ())-      context "when input stream is not empty" $-        it "signals correct error message" $-          property $ \a as -> do-            let s = a : as-            grs  eof s (`shouldFailWith` err posI (utok a <> eeof))-            grs' eof s (`failsLeaving` s)--    describe "token" $ do-      let f x = E.singleton (Tokens $ nes x)-          testChar a x = if x == a then Right x else Left (f x, f a, E.empty)-      context "when supplied predicate is satisfied" $-        it "succeeds" $-          property $ \a as mtok -> do-            let p :: MonadParsec Dec String m => m Char-                p = token (testChar a) mtok-                s = a : as-            grs  p s (`shouldParse` a)-            grs' p s (`succeedsLeaving` as)-      context "when supplied predicate is not satisfied" $-        it "signals correct parse error" $-          property $ \a b as mtok -> a /= b ==> do-            let p :: MonadParsec Dec String m => m Char-                p = token (testChar b) mtok-                s = a : as-            grs  p s (`shouldFailWith` ParseError-              { errorPos        = posI-              , errorUnexpected = E.singleton (Tokens $ nes a)-              , errorExpected   = E.singleton (Tokens $ nes b)-              , errorCustom     = E.empty })-            grs' p s (`failsLeaving` s)-      context "when stream is empty" $-        it "signals correct parse error" $-          property $ \a mtok -> do-            let p :: MonadParsec Dec String m => m Char-                p = token (testChar a) mtok-            grs p "" (`shouldFailWith` ParseError-              { errorPos        = posI-              , errorUnexpected = E.singleton EndOfInput-              , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtok-              , errorCustom     = E.empty })--    describe "tokens" $ do-      context "when stream is prefixed with given string" $-        it "parses the string" $-          property $ \str s -> do-            let p :: MonadParsec Dec String m => m String-                p = tokens (==) str-                s' = str ++ s-            grs  p s' (`shouldParse` str)-            grs' p s' (`succeedsLeaving` s)-      context "when stream is not prefixed with given string" $-        it "signals correct parse error" $-          property $ \str s -> not (str `isPrefixOf` s) ==> do-            let p :: MonadParsec Dec String m => m String-                p = tokens (==) str-                z = toFirstMismatch (==) str s-            grs  p s (`shouldFailWith` err posI (utoks z <> etoks str))-            grs' p s (`failsLeaving` s)--  describe "combinators for manipulating parser state" $ do--    describe "setInput and getInput" $-      it "sets input and gets it back" $-        property $ \s -> do-          let p = do-                st0 <- getInput-                guard (null st0)-                setInput s-                result <- string s-                st1 <- getInput-                guard (null st1)-                return result-          prs p "" `shouldParse` s--    describe "setPosition and getPosition" $-      it "sets position and gets it back" $-        property $ \st pos -> do-          let p :: Parser SourcePos-              p = setPosition pos >> getPosition-              f (State s (_:|xs) tp w) y = State s (y:|xs) tp w-          runParser' p st `shouldBe` (f st pos, Right pos)--    describe "pushPosition" $-      it "adds a layer to position stack and parser continues on that level" $-        property $ \st pos ->  do-          let p :: Parser ()-              p = pushPosition pos-          fst (runParser' p st) `shouldBe`-            st { statePos = NE.cons pos (statePos st) }--    describe "popPosition" $-      it "removes a layer from position stack" $-        property $ \st -> do-          let p :: Parser ()-              p = popPosition-              pos = statePos st-          fst (runParser' p st) `shouldBe`-            st { statePos = fromMaybe pos (snd (NE.uncons pos)) }--    describe "setTokensProcessed and getTokensProcessed" $-      it "sets number of processed toknes and gets it back" $-        property $ \tp -> do-          let p = setTokensProcessed tp >> getTokensProcessed-          prs p "" `shouldParse` tp--    describe "setTabWidth and getTabWidth" $-      it "sets tab width and gets it back" $-        property $ \w -> do-          let p = setTabWidth w >> getTabWidth-          prs p "" `shouldParse` w--    describe "setParserState and getParserState" $-      it "sets parser state and gets it back" $-        property $ \s1 s2 -> do-          let p :: MonadParsec Dec String m => m (State String)-              p = do-                st <- getParserState-                guard (st == State s posI 0 defaultTabWidth)-                setParserState s1-                updateParserState (f s2)-                liftM2 const getParserState (setInput "")-              f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w-              s = ""-          grs p s (`shouldParse` f s2 s1)--  describe "running a parser" $ do-    describe "parseMaybe" $-      it "returns result on success and Nothing on failure" $-        property $ \s s' -> do-          let p = string s' :: Parser String-          parseMaybe p s `shouldBe`-            if s == s' then Just s else Nothing--    describe "runParser'" $-      it "works" $-        property $ \st s -> do-          let p = string s-          runParser' p st `shouldBe` emulateStrParsing st s--    describe "runParserT'" $-      it "works" $-        property $ \st s -> do-          let p = string s-          runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s--  describe "MonadParsec instance of ReaderT" $ do--    describe "try" $-      it "generally works" $-        property $ \pre ch1 ch2 -> do-          let s1 = pre : [ch1]-              s2 = pre : [ch2]-              getS1 = asks fst-              getS2 = asks snd-              p = try (g =<< getS1) <|> (g =<< getS2)-              g = sequence . fmap char-              s = [pre]-          prs (runReaderT p (s1, s2)) s `shouldFailWith`-            err (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \a' b' c' -> do-          let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar-              [a,b,c] = getNonNegative <$> [a',b',c']-              s = abcRow a b c-          if b > 0 || c > 0-            then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'-            else prs (runReaderT p 'a') s `shouldFailWith`-                   err (posN a s) (ueof <> etok 'a')--  describe "MonadParsec instance of lazy StateT" $ do--    describe "(<|>)" $-      it "generally works" $-        property $ \n -> do-          let p = L.put n >>-                ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get-          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "lookAhead" $-      it "generally works" $-        property $ \n -> do-          let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get-          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \n -> do-          let p = do-                L.put n-                let notEof = notFollowedBy (L.modify (* 2) >> eof)-                some (try (anyChar <* notEof)) <* char 'x'-          prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect state" $-          property $ \m n -> do-            let p = do-                  L.put m-                  observing (L.modify (+ n))-            prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)-      context "when inner parser fails" $-        it "cannot affect state" $-          property $ \m n -> do-            let p = do-                  L.put m-                  observing (L.modify (+ n) <* empty)-            prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)--  describe "MonadParsec instance of strict StateT" $ do--    describe "(<|>)" $-      it "generally works" $-        property $ \n -> do-          let p = S.put n >>-                ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get-          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "lookAhead" $-      it "generally works" $-        property $ \n -> do-          let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get-          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)--    describe "notFollowedBy" $-      it "generally works" $-        property $ \n -> do-          let p = do-                S.put n-                let notEof = notFollowedBy (S.modify (* 2) >> eof)-                some (try (anyChar <* notEof)) <* char 'x'-          prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect state" $-          property $ \m n -> do-            let p = do-                  S.put m-                  observing (L.modify (+ n))-            prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)-      context "when inner parser fails" $-        it "cannot affect state" $-          property $ \m n -> do-            let p = do-                  S.put m-                  observing (L.modify (+ n) <* empty)-            prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)--  describe "MonadParsec instance of lazy WriterT" $ do--    it "generally works" $-      property $ \pre post -> do-        let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x-            loggedEof    = eof >> L.tell "EOF"-            p = do-              L.tell pre-              cs <- L.censor (fmap toUpper) $-                some (try (loggedLetter <* notFollowedBy loggedEof))-              L.tell post-              void loggedLetter-              return cs-        prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")--    describe "lookAhead" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (L.tell [w])-          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "notFollowedBy" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (L.tell [w] <* char 'a')-          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect log" $-          property $ \n -> do-            let p = observing (L.tell $ Sum n)-            prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)-      context "when inner parser fails" $-        it "cannot affect log" $-          property $ \n -> do-            let p = observing (L.tell (Sum n) <* empty)-            prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)--  describe "MonadParsec instance of strict WriterT" $ do--    it "generally works" $-      property $ \pre post -> do-        let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x-            loggedEof    = eof >> S.tell "EOF"-            p = do-              S.tell pre-              cs <- L.censor (fmap toUpper) $-                some (try (loggedLetter <* notFollowedBy loggedEof))-              S.tell post-              void loggedLetter-              return cs-        prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")--    describe "lookAhead" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (S.tell [w])-          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "notFollowedBy" $-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (S.tell [w] <* char 'a')-          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])--    describe "observing" $ do-      context "when inner parser succeeds" $-        it "can affect log" $-          property $ \n -> do-            let p = observing (S.tell $ Sum n)-            prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)-      context "when inner parser fails" $-        it "cannot affect log" $-          property $ \n -> do-            let p = observing (S.tell (Sum n) <* empty)-            prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)--  describe "MonadParsec instance of lazy RWST" $ do--    describe "label" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = label "a" ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "try" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = try ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "lookAhead" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = lookAhead ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (L.tell [w])-          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = lookAhead (L.put s1)-          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "notFollowedBy" $ do-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (L.tell [w] <* char 'a')-          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = notFollowedBy (L.put s1 <* char 'a')-          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "withRecovery" $ do-      it "allows main parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "allows recovering parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "observing" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = observing ((,) <$> L.ask <*> L.get)-          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            (Right (r, s), s, mempty :: [Int])-      context "when the inner parser fails" $-        it "backtracks state" $-          property $ \r s0 s1 -> (s0 /= s1) ==> do-            let p = observing (L.put s1 <* empty)-            prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`-              (Left (err posI mempty), s0, mempty :: [Int])--  describe "MonadParsec instance of strict RWST" $ do--    describe "label" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = label "a" ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "try" $-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = try ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "lookAhead" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = lookAhead ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = lookAhead (S.tell [w])-          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = lookAhead (S.put s1)-          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "notFollowedBy" $ do-      it "discards what writer tells inside it" $-        property $ \w -> do-          let p = notFollowedBy (S.tell [w] <* char 'a')-          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`-            ((), 0, mempty :: [Int])-      it "does not allow to influence state outside it" $-        property $ \s0 s1 -> (s0 /= s1) ==> do-          let p = notFollowedBy (S.put s1 <* char 'a')-          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`-            ((), s0, mempty :: [Int])--    describe "withRecovery" $ do-      it "allows main parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])-      it "allows recovering parser to access reader context and state inside it" $-        property $ \r s -> do-          let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            ((r, s), s, mempty :: [Int])--    describe "observing" $ do-      it "allows to access reader context and state inside it" $-        property $ \r s -> do-          let p = observing ((,) <$> S.ask <*> S.get)-          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`-            (Right (r, s), s, mempty :: [Int])-      context "when the inner parser fails" $-        it "backtracks state" $-          property $ \r s0 s1 -> (s0 /= s1) ==> do-            let p = observing (S.put s1 <* empty)-            prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`-              (Left (err posI mempty), s0, mempty :: [Int])--  describe "dbg" $ do-    -- NOTE We don't test properties here to avoid flood of debugging output-    -- when the test runs.-    context "when inner parser succeeds consuming input" $ do-      it "has no effect on how parser works" $ do-        let p = dbg "char" (char 'a')-            s = "ab"-        prs  p s `shouldParse` 'a'-        prs' p s `succeedsLeaving` "b"-      it "its hints are preserved" $ do-        let p = dbg "many chars" (many (char 'a')) <* empty-            s = "abcd"-        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (etok 'a')-        prs' p s `failsLeaving` "bcd"-    context "when inner parser fails consuming input" $-      it "has no effect on how parser works" $ do-        let p = dbg "chars" (char 'a' *> char 'c')-            s = "abc"-        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')-        prs' p s `failsLeaving` "bc"-    context "when inner parser succeeds without consuming" $ do-      it "has no effect on how parser works" $ do-        let p = dbg "return" (return 'a')-            s = "abc"-        prs  p s `shouldParse` 'a'-        prs' p s `succeedsLeaving` s-      it "its hints are preserved" $ do-        let p = dbg "many chars" (many (char 'a')) <* empty-            s = "bcd"-        prs  p s `shouldFailWith` err posI (etok 'a')-        prs' p s `failsLeaving` "bcd"-    context "when inner parser fails without consuming" $-      it "has no effect on how parser works" $ do-        let p = dbg "empty" (void empty)-            s = "abc"-        prs  p s `shouldFailWith` err posI mempty-        prs' p s `failsLeaving` s--------------------------------------------------------------------------------- Helpers--byteToChar :: Word8 -> Char-byteToChar = chr . fromIntegral---- | This data type represents tokens in custom input stream.--data Span = Span-  { spanStart :: SourcePos-  , spanEnd   :: SourcePos-  , spanBody  :: NonEmpty Char-  } deriving (Eq, Ord, Show)--instance Stream [Span] where-  type Token [Span] = Span-  uncons [] = Nothing-  uncons (t:ts) = Just (t, ts)-  updatePos _ _ _ (Span start end _) = (start, end)--instance Arbitrary Span where-  arbitrary = do-    start <- arbitrary-    end   <- arbitrary `suchThat` (> start)-    Span start end <$>-      (NE.fromList . getNonEmpty <$> arbitrary)--instance ShowToken Span where-  showTokens ts = concat (NE.toList . spanBody <$> ts)--type CustomParser = Parsec Dec [Span]--pSpan :: Span -> CustomParser Span-pSpan span = token testToken (Just span)-  where-    f = E.singleton . Tokens . nes-    testToken x =-      if spanBody x == spanBody span-        then Right span-        else Left (f x, f span , E.empty)--incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])-incCoincidence st ts = do-  n <- getSmall <$> arbitrary-  let (pre, post) = splitAt n (stateInput st)-      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts-  return st { stateInput = pre' ++ post }--emulateStrParsing-  :: State String-  -> String-  -> (State String, Either (ParseError Char Dec) String)-emulateStrParsing st@(State i (pos:|z) tp w) s =-  if l == length s-    then (State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w, Right s)-    else (st, Left $ err (pos:|z) (etoks s <> utoks (take (l + 1) i)))-  where l = length (takeWhile id $ zipWith (==) s i)
+ tests/Text/Megaparsec/StreamSpec.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.StreamSpec (spec) where++import Data.Char (isLetter, chr)+import Data.Proxy+import Data.Semigroup ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec+import qualified Data.ByteString      as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text            as T+import qualified Data.Text.Lazy       as TL++spec :: Spec+spec = do++  describe "String instance of Stream" $ do+    describe "tokenToChunk" $+      it "produces the same result as singleton with tokensToChunk" $+        property $ \ch ->+          tokenToChunk sproxy ch === tokensToChunk sproxy [ch]+    describe "tokensToChunk" $+      it "list of tokens is isomorphic to chunk" $+        property $ \ts ->+          chunkToTokens sproxy (tokensToChunk sproxy ts) === ts+    describe "chunkToTokens" $+      it "chunk is isomorphic to list of tokens" $+        property $ \chunk ->+          tokensToChunk sproxy (chunkToTokens sproxy chunk) === chunk+    describe "chunkLength" $+      it "returns correct length of given chunk" $+        property $ \chunk ->+          chunkLength sproxy chunk === length chunk+    describe "chunkEmpty" $+      it "only true when chunkLength returns 0" $+        property $ \chunk ->+          chunkEmpty sproxy chunk === (chunkLength sproxy chunk <= 0)+    describe "positionAt1" $+      it "just returns the given position" $+        property $ \pos t ->+          positionAt1 sproxy pos t === pos+    describe "positionAtN" $+      it "just returns the given position" $+        property $ \pos chunk ->+          positionAtN sproxy pos chunk === pos+    describe "advance1" $ do+      context "when given newline" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l _) ->+            advance1 sproxy w pos '\n' === SourcePos n (l <> pos1) pos1+      context "when given tab" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l c) ->+            advance1 sproxy w pos '\t' === SourcePos n l (toNextTab w c)+      context "when given other character" $+        it "works correctly" $+          property $ \ch w pos@(SourcePos n l c) ->+            (ch /= '\n' && ch /= '\t') ==>+              advance1 sproxy w pos ch === SourcePos n l (c <> pos1)+    describe "advanceN" $+      it "works correctly" $+        advanceN sproxy defaultTabWidth (initialPos "") "something\n\tfoo"+          === SourcePos "" (mkPos 2) (mkPos 12)+    describe "take1_" $ do+      context "when input in empty" $+        it "returns Nothing" $+          take1_ ("" :: String) === Nothing+      context "when input is not empty" $+        it "unconses a token" $+          property $ \s -> not (null s) ==>+            take1_ (s :: String) === Just (head s, tail s)+    describe "takeN_" $ do+      context "requested length is 0" $+        it "returns Just empty chunk and original stream" $+          property $ \s ->+            takeN_ 0 (s :: String) === Just ("", s)+      context "requested length is greater than 0" $ do+        context "stream is empty" $+          it "returns Nothing" $+            property $ \(Positive n) ->+              takeN_ n ("" :: String) === Nothing+        context "stream is not empty" $+          it "returns a chunk of correct length and rest of the stream" $+            property $ \(Positive n) s -> not (null s) ==>+              takeN_ n (s :: String) === Just (splitAt n s)+    describe "takeWhile_" $+      it "extracts a chunk that is a prefix consisting of matching tokens" $+        property $ \s ->+          takeWhile_ isLetter s === span isLetter s++  describe "ByteString instance of Stream" $ do+    describe "tokenToChunk" $+      it "produces the same result as singleton with tokensToChunk" $+        property $ \ch ->+          tokenToChunk bproxy ch === tokensToChunk bproxy [ch]+    describe "tokensToChunk" $+      it "list of tokens is isomorphic to chunk" $+        property $ \ts ->+          chunkToTokens bproxy (tokensToChunk bproxy ts) === ts+    describe "chunkToTokens" $+      it "chunk is isomorphic to list of tokens" $+        property $ \chunk ->+          tokensToChunk bproxy (chunkToTokens bproxy chunk) === chunk+    describe "chunkLength" $+      it "returns correct length of given chunk" $+        property $ \chunk ->+          chunkLength bproxy chunk === B.length chunk+    describe "chunkEmpty" $+      it "only true when chunkLength returns 0" $+        property $ \chunk ->+          chunkEmpty bproxy chunk === (chunkLength bproxy chunk <= 0)+    describe "positionAt1" $+      it "just returns the given position" $+        property $ \pos t ->+          positionAt1 bproxy pos t === pos+    describe "positionAtN" $+      it "just returns the given position" $+        property $ \pos chunk ->+          positionAtN bproxy pos chunk === pos+    describe "advance1" $ do+      context "when given newline" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l _) ->+            advance1 bproxy w pos 10 === SourcePos n (l <> pos1) pos1+      context "when given tab" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l c) ->+            advance1 bproxy w pos 9 === SourcePos n l (toNextTab w c)+      context "when given other character" $+        it "works correctly" $+          property $ \ch w pos@(SourcePos n l c) ->+            (ch /= 10 && ch /= 9) ==>+              advance1 bproxy w pos ch === SourcePos n l (c <> pos1)+    describe "advanceN" $+      it "works correctly" $+        advanceN bproxy defaultTabWidth (initialPos "") "something\n\tfoo"+          === SourcePos "" (mkPos 2) (mkPos 12)+    describe "take1_" $ do+      context "when input in empty" $+        it "returns Nothing" $+          take1_ ("" :: B.ByteString) === Nothing+      context "when input is not empty" $+        it "unconses a token" $+          property $ \s -> not (B.null s) ==>+            take1_ (s :: B.ByteString) === B.uncons s+    describe "takeN_" $ do+      context "requested length is 0" $+        it "returns Just empty chunk and original stream" $+          property $ \s ->+            takeN_ 0 (s :: B.ByteString) === Just ("", s)+      context "requested length is greater than 0" $ do+        context "stream is empty" $+          it "returns Nothing" $+            property $ \(Positive n) ->+              takeN_ n ("" :: B.ByteString) === Nothing+        context "stream is not empty" $+          it "returns a chunk of correct length and rest of the stream" $+            property $ \(Positive n) s -> not (B.null s) ==>+              takeN_ n (s :: B.ByteString) === Just (B.splitAt n s)+    describe "takeWhile_" $+      it "extracts a chunk that is a prefix consisting of matching tokens" $+        property $ \s ->+          let f = isLetter . chr . fromIntegral+          in takeWhile_ f s === B.span f s++  describe "Lazy ByteString instance of Stream" $ do+    describe "tokenToChunk" $+      it "produces the same result as singleton with tokensToChunk" $+        property $ \ch ->+          tokenToChunk blproxy ch === tokensToChunk blproxy [ch]+    describe "tokensToChunk" $+      it "list of tokens is isomorphic to chunk" $+        property $ \ts ->+          chunkToTokens blproxy (tokensToChunk blproxy ts) === ts+    describe "chunkToTokens" $+      it "chunk is isomorphic to list of tokens" $+        property $ \chunk ->+          tokensToChunk blproxy (chunkToTokens blproxy chunk) === chunk+    describe "chunkLength" $+      it "returns correct length of given chunk" $+        property $ \chunk ->+          chunkLength blproxy chunk === fromIntegral (BL.length chunk)+    describe "chunkEmpty" $+      it "only true when chunkLength returns 0" $+        property $ \chunk ->+          chunkEmpty blproxy chunk === (chunkLength blproxy chunk <= 0)+    describe "positionAt1" $+      it "just returns the given position" $+        property $ \pos t ->+          positionAt1 blproxy pos t === pos+    describe "positionAtN" $+      it "just returns the given position" $+        property $ \pos chunk ->+          positionAtN blproxy pos chunk === pos+    describe "advance1" $ do+      context "when given newline" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l _) ->+            advance1 blproxy w pos 10 === SourcePos n (l <> pos1) pos1+      context "when given tab" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l c) ->+            advance1 blproxy w pos 9 === SourcePos n l (toNextTab w c)+      context "when given other character" $+        it "works correctly" $+          property $ \ch w pos@(SourcePos n l c) ->+            (ch /= 10 && ch /= 9) ==>+              advance1 blproxy w pos ch === SourcePos n l (c <> pos1)+    describe "advanceN" $+      it "works correctly" $+        advanceN blproxy defaultTabWidth (initialPos "") "something\n\tfoo"+          === SourcePos "" (mkPos 2) (mkPos 12)+    describe "take1_" $ do+      context "when input in empty" $+        it "returns Nothing" $+          take1_ ("" :: BL.ByteString) === Nothing+      context "when input is not empty" $+        it "unconses a token" $+          property $ \s -> not (BL.null s) ==>+            take1_ (s :: BL.ByteString) === BL.uncons s+    describe "takeN_" $ do+      context "requested length is 0" $+        it "returns Just empty chunk and original stream" $+          property $ \s ->+            takeN_ 0 (s :: BL.ByteString) === Just ("", s)+      context "requested length is greater than 0" $ do+        context "stream is empty" $+          it "returns Nothing" $+            property $ \(Positive n) ->+              takeN_ n ("" :: BL.ByteString) === Nothing+        context "stream is not empty" $+          it "returns a chunk of correct length and rest of the stream" $+            property $ \(Positive n) s -> not (BL.null s) ==>+              takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s)+    describe "takeWhile_" $+      it "extracts a chunk that is a prefix consisting of matching tokens" $+        property $ \s ->+          let f = isLetter . chr . fromIntegral+          in takeWhile_ f s === BL.span f s++  describe "Text instance of Stream" $ do+    describe "tokenToChunk" $+      it "produces the same result as singleton with tokensToChunk" $+        property $ \ch ->+          tokenToChunk tproxy ch === tokensToChunk tproxy [ch]+    describe "tokensToChunk" $+      it "list of tokens is isomorphic to chunk" $+        property $ \ts ->+          chunkToTokens tproxy (tokensToChunk tproxy ts) === ts+    describe "chunkToTokens" $+      it "chunk is isomorphic to list of tokens" $+        property $ \chunk ->+          tokensToChunk tproxy (chunkToTokens tproxy chunk) === chunk+    describe "chunkLength" $+      it "returns correct length of given chunk" $+        property $ \chunk ->+          chunkLength tproxy chunk === T.length chunk+    describe "chunkEmpty" $+      it "only true when chunkLength returns 0" $+        property $ \chunk ->+          chunkEmpty tproxy chunk === (chunkLength tproxy chunk <= 0)+    describe "positionAt1" $+      it "just returns the given position" $+        property $ \pos t ->+          positionAt1 tproxy pos t === pos+    describe "positionAtN" $+      it "just returns the given position" $+        property $ \pos chunk ->+          positionAtN tproxy pos chunk === pos+    describe "advance1" $ do+      context "when given newline" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l _) ->+            advance1 tproxy w pos '\n' === SourcePos n (l <> pos1) pos1+      context "when given tab" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l c) ->+            advance1 tproxy w pos '\t' === SourcePos n l (toNextTab w c)+      context "when given other character" $+        it "works correctly" $+          property $ \ch w pos@(SourcePos n l c) ->+            (ch /= '\n' && ch /= '\t') ==>+              advance1 tproxy w pos ch === SourcePos n l (c <> pos1)+    describe "advanceN" $+      it "works correctly" $+        advanceN tproxy defaultTabWidth (initialPos "") "something\n\tfoo"+          === SourcePos "" (mkPos 2) (mkPos 12)+    describe "take1_" $ do+      context "when input in empty" $+        it "returns Nothing" $+          take1_ ("" :: T.Text) === Nothing+      context "when input is not empty" $+        it "unconses a token" $+          property $ \s -> not (T.null s) ==>+            take1_ (s :: T.Text) === T.uncons s+    describe "takeN_" $ do+      context "requested length is 0" $+        it "returns Just empty chunk and original stream" $+          property $ \s ->+            takeN_ 0 (s :: T.Text) === Just ("", s)+      context "requested length is greater than 0" $ do+        context "stream is empty" $+          it "returns Nothing" $+            property $ \(Positive n) ->+              takeN_ n ("" :: T.Text) === Nothing+        context "stream is not empty" $+          it "returns a chunk of correct length and rest of the stream" $+            property $ \(Positive n) s -> not (T.null s) ==>+              takeN_ n (s :: T.Text) === Just (T.splitAt n s)+    describe "takeWhile_" $+      it "extracts a chunk that is a prefix consisting of matching tokens" $+        property $ \s ->+          takeWhile_ isLetter s === T.span isLetter s++  describe "Lazy Text instance of Stream" $ do+    describe "tokenToChunk" $+      it "produces the same result as singleton with tokensToChunk" $+        property $ \ch ->+          tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch]+    describe "tokensToChunk" $+      it "list of tokens is isomorphic to chunk" $+        property $ \ts ->+          chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts+    describe "chunkToTokens" $+      it "chunk is isomorphic to list of tokens" $+        property $ \chunk ->+          tokensToChunk tlproxy (chunkToTokens tlproxy chunk) === chunk+    describe "chunkLength" $+      it "returns correct length of given chunk" $+        property $ \chunk ->+          chunkLength tlproxy chunk === fromIntegral (TL.length chunk)+    describe "chunkEmpty" $+      it "only true when chunkLength returns 0" $+        property $ \chunk ->+          chunkEmpty tlproxy chunk === (chunkLength tlproxy chunk <= 0)+    describe "positionAt1" $+      it "just returns the given position" $+        property $ \pos t ->+          positionAt1 tlproxy pos t === pos+    describe "positionAtN" $+      it "just returns the given position" $+        property $ \pos chunk ->+          positionAtN tlproxy pos chunk === pos+    describe "advance1" $ do+      context "when given newline" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l _) ->+            advance1 tlproxy w pos '\n' === SourcePos n (l <> pos1) pos1+      context "when given tab" $+        it "works correctly" $+          property $ \w pos@(SourcePos n l c) ->+            advance1 tlproxy w pos '\t' === SourcePos n l (toNextTab w c)+      context "when given other character" $+        it "works correctly" $+          property $ \ch w pos@(SourcePos n l c) ->+            (ch /= '\n' && ch /= '\t') ==>+              advance1 tlproxy w pos ch === SourcePos n l (c <> pos1)+    describe "advanceN" $+      it "works correctly" $+        advanceN tlproxy defaultTabWidth (initialPos "") "something\n\tfoo"+          === SourcePos "" (mkPos 2) (mkPos 12)+    describe "take1_" $ do+      context "when input in empty" $+        it "returns Nothing" $+          take1_ ("" :: TL.Text) === Nothing+      context "when input is not empty" $+        it "unconses a token" $+          property $ \s -> not (TL.null s) ==>+            take1_ (s :: TL.Text) === TL.uncons s+    describe "takeN_" $ do+      context "requested length is 0" $+        it "returns Just empty chunk and original stream" $+          property $ \s ->+            takeN_ 0 (s :: TL.Text) === Just ("", s)+      context "requested length is greater than 0" $ do+        context "stream is empty" $+          it "returns Nothing" $+            property $ \(Positive n) ->+              takeN_ n ("" :: TL.Text) === Nothing+        context "stream is not empty" $+          it "returns a chunk of correct length and rest of the stream" $+            property $ \(Positive n) s -> not (TL.null s) ==>+              takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s)+    describe "takeWhile_" $+      it "extracts a chunk that is a prefix consisting of matching tokens" $+        property $ \s ->+          takeWhile_ isLetter s === TL.span isLetter s++----------------------------------------------------------------------------+-- Helpers++toNextTab :: Pos -> Pos -> Pos+toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w)+  where+    w = unPos w'+    c = unPos c'++sproxy :: Proxy String+sproxy = Proxy++bproxy :: Proxy B.ByteString+bproxy = Proxy++blproxy :: Proxy BL.ByteString+blproxy = Proxy++tproxy :: Proxy T.Text+tproxy = Proxy++tlproxy :: Proxy TL.Text+tlproxy = Proxy
+ tests/Text/MegaparsecSpec.hs view
@@ -0,0 +1,1768 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE Rank2Types        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE RecursiveDo       #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -fno-warn-orphans  #-}++module Text.MegaparsecSpec (spec) where++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.Identity+import Control.Monad.Reader+import Data.Char (toUpper, 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.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++#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 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 "" ""+            S.execState v 0 `shouldBe` n++    describe "some" $ do+      context "when stream begins with things argument of some parses" $+        it "they are parsed" $+          property $ \a' b' c' -> do+            let a = getPositive a'+                [b,c] = getNonNegative <$> [b',c']+                p = some (char 'a')+                s = abcRow a b c+            prs  p s `shouldParse` replicate a 'a'+            prs' p s `succeedsLeaving` drop a s+      context "when stream does not begin with thing argument of some parses" $+        it "signals correct parse error" $+          property $ \a' b' c' -> do+            let [a,b,c] = getNonNegative <$> [a',b',c']+                p = some (char 'd')+                s = abcRow a b c ++ "g"+            prs  p s `shouldFailWith` err posI (utok (head s) <> etok 'd')+            prs' p s `failsLeaving` s+      context "when stream is empty" $+        it "signals correct parse error" $+          property $ \ch -> do+            let p = some (char ch)+            prs  p "" `shouldFailWith` err posI (ueof <> etok ch)+    context "optional" $ do+      context "when stream begins with that optional thing" $+        it "parses it" $+          property $ \a b -> do+            let p = optional (char a) <* char b+                s = [a,b]+            prs  p s `shouldParse` Just a+            prs' p s `succeedsLeaving` ""+      context "when stream does not begin with that optional thing" $+        it "succeeds parsing nothing" $+          property $ \a b -> a /= b ==> do+            let p = optional (char a) <* char b+                s = [b]+            prs  p s `shouldParse` Nothing+            prs' p s `succeedsLeaving` ""+      context "when stream is empty" $+        it "succeeds parsing nothing" $+          property $ \a -> do+            let p = optional (char a)+            prs  p "" `shouldParse` Nothing++  describe "ParsecT Monad instance" $ do+    it "satisfies left identity law" $+      property $ \a k' -> do+        let k = return . (+ k')+            p = return (a :: Int) >>= k+        prs p "" `shouldBe` prs (k a) ""+    it "satisfies right identity law" $+      property $ \a -> do+        let m = return (a :: Int)+            p = m >>= return+        prs p "" `shouldBe` prs m ""+    it "satisfies associativity law" $+      property $ \m' k' h' -> do+        let m = return (m' :: Int)+            k = return . (+ k')+            h = return . (* h')+            p = m >>= (\x -> k x >>= h)+            p' = (m >>= k) >>= h+        prs p "" `shouldBe` prs p' ""+    it "fails signals correct parse error" $+      property $ \msg -> do+        let p = fail msg :: Parsec Void String ()+        prs p "" `shouldFailWith` errFancy posI (fancy $ ErrorFail msg)+    it "pure is the same as return" $+      property $ \n ->+        prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""+    it "(<*>) is the same as ap" $+      property $ \m' k' -> do+        let m = return (m' :: Int)+            k = return (+ k')+        prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""++  describe "ParsecT MonadFail instance" $+    describe "fail" $+      it "signals correct parse error" $+        property $ \s msg -> do+          let p = void (fail msg)+          prs  p s `shouldFailWith` errFancy posI (fancy $ ErrorFail msg)+          prs' p s `failsLeaving` s++  describe "ParsecT MonadIO instance" $+    it "liftIO works" $+      property $ \n -> do+        let p = liftIO (return n) :: ParsecT Void String IO Integer+        runParserT p "" "" `shouldReturn` Right n++  describe "ParsecT MonadFix instance" $+    it "withRange works" $ do+      let+        withRange+          :: (MonadParsec e s m, MonadFix m)+          => ((SourcePos,SourcePos) -> m a)+          -> m a+        withRange f = do+          Just p1 <- getNextTokenPosition+          rec+            r <- f (p1, p2)+            p2 <- getPosition+          return r+        p :: Parsec Void String (SourcePos,SourcePos)+        p = withRange $ \pp -> pp <$ string "ab"+      runParser p "" "abcd"+        `shouldBe` Right+        ( SourcePos "" (mkPos 1) (mkPos 1)+        , SourcePos "" (mkPos 1) (mkPos 3)+        )++  describe "ParsecT MonadReader instance" $ do++    describe "ask" $+      it "returns correct value of context" $+        property $ \n -> do+          let p = ask :: ParsecT Void String (Reader Integer) Integer+          runReader (runParserT p "" "") n `shouldBe` Right n++    describe "local" $+      it "modifies reader context correctly" $+        property $ \n k -> do+          let p = local (+ k) ask :: ParsecT Void String (Reader Integer) Integer+          runReader (runParserT p "" "") n `shouldBe` Right (n + k)++  describe "ParsecT MonadState instance" $ do++    describe "get" $+      it "returns correct state value" $+        property $ \n -> do+          let p = L.get :: ParsecT Void String (L.State Integer) Integer+          L.evalState (runParserT p "" "") n `shouldBe` Right n+    describe "put" $+      it "replaces state value" $+        property $ \a b -> do+          let p = L.put b :: ParsecT Void String (L.State Integer) ()+          L.execState (runParserT p "" "") a `shouldBe` b++  describe "ParsecT MonadCont instance" $++    describe "callCC" $+      it "works properly" $+        property $ \a b -> do+          let p :: ParsecT Void String (Cont (Either (ParseError Char Void) Integer)) Integer+              p = callCC $ \e -> when (a > b) (e a) >> return b+          runCont (runParserT p "" "") id `shouldBe` Right (max a b)++  describe "ParsecT MonadError instance" $ do++    describe "throwError" $+      it "throws the error" $+        property $ \a b -> do+          let p :: ParsecT Void String (Except Integer) Integer+              p = throwError a >> return b+          runExcept (runParserT p "" "") `shouldBe` Left a++    describe "catchError" $+      it "catches the error" $+        property $ \a b -> do+          let p :: ParsecT Void String (Except Integer) Integer+              p = (throwError a >> return b) `catchError` handler+              handler e = return (e + b)+          runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)++  describe "primitive combinators" $ do++    describe "failure" $+      it "signals correct parse error" $+        property $ \us ps -> do+          let p :: MonadParsec Void String m => m ()+              p = void (failure us ps)+          grs p "" (`shouldFailWith` TrivialError posI us ps)++    describe "fancyFailure" $+      it "singals correct parse error" $+        property $ \xs -> do+          let p :: MonadParsec Void String m => m ()+              p = void (fancyFailure xs)+          grs p "" (`shouldFailWith` FancyError posI xs)++    describe "label" $ do+      context "when inner parser succeeds consuming input" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Void String m => m Char+                  p = label lbl (char a) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+        context "inner parser produces hints" $+          it "replaces the last hint with “the rest of <label>”" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Void String m => m String+                  p = label lbl (many (char a)) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (elabel $ "the rest of " ++ lbl))+              grs' p s (`failsLeaving` "")+      context "when inner parser consumes and fails" $+        it "reports parse error without modification" $+          property $ \lbl a b c -> not (null lbl) && b /= c ==> do+            let p :: MonadParsec Void String m => m Char+                p = label lbl (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Void String m => m Char+                  p = label lbl (return a) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+        context "inner parser produces hints" $+          it "replaces the last hint with given label" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Void String m => m String+                  p = label lbl (many (char a)) <* empty+              grs p "" (`shouldFailWith` err posI (elabel lbl))+      context "when inner parser fails without consuming" $+        it "is mentioned in parse error via its label" $+          property $ \lbl -> not (null lbl) ==> do+            let p :: MonadParsec Void String m => m ()+                p = label lbl empty+            grs p "" (`shouldFailWith` err posI (elabel lbl))++    describe "hidden" $ do+      context "when inner parser succeeds consuming input" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \a -> do+              let p :: MonadParsec Void String m => m Char+                  p = hidden (char a) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+        context "inner parser produces hints" $+          it "hides the parser in the error message" $+            property $ \a -> do+              let p :: MonadParsec Void String m => m String+                  p = hidden (many (char a)) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+      context "when inner parser consumes and fails" $+        it "reports parse error without modification" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Void String m => m Char+                p = hidden (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \a -> do+              let p :: MonadParsec Void String m => m Char+                  p = hidden (return a) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+        context "inner parser produces hints" $+          it "hides the parser in the error message" $+            property $ \a -> do+              let p :: MonadParsec Void String m => m String+                  p = hidden (many (char a)) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+      context "when inner parser fails without consuming" $+        it "hides the parser in the error message" $ do+          let p :: MonadParsec Void String m => m ()+              p = hidden empty+          grs p "" (`shouldFailWith` err posI mempty)++    describe "try" $ do+      context "when inner parser succeeds consuming" $+        it "try has no effect" $+          property $ \a -> do+            let p :: MonadParsec Void String m => m Char+                p = try (char a)+                s = [a]+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` "")+      context "when inner parser fails consuming" $+        it "backtracks, it appears as if the parser has not consumed anything" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Void String m => m Char+                p = try (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` s)+      context "when inner parser succeeds without consuming" $+        it "try has no effect" $+          property $ \a -> do+            let p :: MonadParsec Void String m => m Char+                p = try (return a)+            grs p "" (`shouldParse` a)+      context "when inner parser fails without consuming" $+        it "try backtracks parser state anyway" $+          property $ \w -> do+            let p :: MonadParsec Void String m => m Char+                p = try (setTabWidth w *> empty)+            grs  p "" (`shouldFailWith` err posI mempty)+            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)++    describe "lookAhead" $ do+      context "when inner parser succeeds consuming" $ do+        it "result is returned but parser state is not changed" $+          property $ \a w -> do+            let p :: MonadParsec Void String m => m Pos+                p = lookAhead (setTabWidth w *> char a) *> getTabWidth+                s = [a]+            grs  p s (`shouldParse` defaultTabWidth)+            grs' p s (`succeedsLeaving` s)+        it "hints are not preserved" $+          property $ \a -> do+            let p :: MonadParsec Void String m => m String+                p = lookAhead (many (char a)) <* empty+                s = [a]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser fails consuming" $+        it "error message is reported as usual" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Void String m => m Char+                p = lookAhead (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        it "result is returned but parser state in not changed" $+          property $ \a w -> do+            let p :: MonadParsec Void String m => m Pos+                p = lookAhead (setTabWidth w *> char a) *> getTabWidth+                s = [a]+            grs  p s (`shouldParse` defaultTabWidth)+            grs' p s (`succeedsLeaving` s)+        it "hints are not preserved" $+          property $ \a b -> a /= b ==> do+            let p :: MonadParsec Void String m => m String+                p = lookAhead (many (char a)) <* empty+                s = [b]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser fails without consuming" $+        it "error message is reported as usual" $ do+          let p :: MonadParsec Void String m => m Char+              p = lookAhead empty+          grs p "" (`shouldFailWith` err posI mempty)++    describe "notFollowedBy" $ do+      context "when inner parser succeeds consuming" $+        it "signals correct parse error" $+          property $ \a w -> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (setTabWidth w <* char a)+                s = [a]+            grs  p s (`shouldFailWith` err posI (utok a))+            grs' p s (`failsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+      context "when inner parser fails consuming" $ do+        it "succeeds without consuming" $+          property $ \a b c w -> b /= c ==> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (setTabWidth w *> char a *> char b)+                s = [a,c]+            grs' p s (`succeedsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+        it "hints are not preserved" $+          property $ \a b -> a /= b ==> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (char b *> many (char a) <* char a) <* empty+                s = [b,b]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser succeeds without consuming" $+        it "signals correct parse error" $+          property $ \a w -> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (setTabWidth w *> return a)+                s = [a]+            grs  p s (`shouldFailWith` err posI (utok a))+            grs' p s (`failsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+      context "when inner parser fails without consuming" $ do+        it "succeeds without consuming" $+          property $ \w -> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (setTabWidth w *> empty)+            grs  p "" (`shouldParse` ())+            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+        it "hints are not preserved" $+          property $ \a -> do+            let p :: MonadParsec Void String m => m ()+                p = notFollowedBy (many (char a) <* char a) <* empty+                s = ""+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)++    describe "withRecovery" $ do+      context "when inner parser succeeds consuming" $+        it "the result is returned as usual" $+          property $ \a as -> do+            let p :: MonadParsec Void String m => m (Maybe Char)+                p = withRecovery (const $ return Nothing) (pure <$> char a)+                s = a : as+            grs  p s (`shouldParse` Just a)+            grs' p s (`succeedsLeaving` as)+      context "when inner parser fails consuming" $ do+        context "when recovering parser succeeds consuming input" $ do+          it "its result is returned and position is advanced" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ string (c : as))+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+              grs' p s (`succeedsLeaving` "")+          it "hints are not preserved" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ string (c : as))+                        (Right <$> char a <* many (char b) <* char b) <* empty+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (length s) s) mempty)+              grs' p s (`failsLeaving` "")+        context "when recovering parser fails consuming input" $+          it "the original parse error (and state) is reported" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ char c <* empty)+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+              grs' p s (`failsLeaving` (c : as))+        context "when recovering parser succeeds without consuming" $ do+          it "its result is returned (and state)" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (return . Left) (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+              grs' p s (`succeedsLeaving` (c : as))+          it "original hints are preserved" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (return . Left)+                        (Right <$> char a <* many (char b) <* char b) <* empty+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (etok b))+              grs' p s (`failsLeaving` (c:as))+        context "when recovering parser fails without consuming" $+          it "the original parse error (and state) is reported" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ empty)+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+              grs' p s (`failsLeaving` (c : as))+      context "when inner parser succeeds without consuming" $+        it "the result is returned as usual" $+          property $ \a s -> do+            let p :: MonadParsec Void String m => m (Maybe Char)+                p = withRecovery (const $ return Nothing) (return a)+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` s)+      context "when inner parser fails without consuming" $ do+        context "when recovering parser succeeds consuming input" $+          it "its result is returned and position is advanced" $+            property $ \a as -> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ string s) empty+                  s = a : as+              grs  p s (`shouldParse` Left (err posI mempty))+              grs' p s (`succeedsLeaving` "")+        context "when recovering parser fails consuming input" $+          it "the original parse error (and state) is reported" $+            property $ \a b as -> a /= b ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ char a <* char b <* empty)+                        (Right <$> empty)+                  s = a : as+              grs  p s (`shouldFailWith` err posI mempty)+              grs' p s (`failsLeaving` s)+        context "when recovering parser succeeds without consuming" $ do+          it "its result is returned (and state)" $+            property $ \s -> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (return . Left) empty+              grs  p s (`shouldParse` Left (err posI mempty))+              grs' p s (`succeedsLeaving` s)+          it "original hints are preserved" $+            property $ \a b as -> a /= b ==> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) String)+                  p = withRecovery (return . Left)+                        (Right <$> many (char a) <* empty) <* empty+                  s = b : as+              grs  p s (`shouldFailWith` err posI (etok a))+              grs' p s (`failsLeaving` s)+        context "when recovering parser fails without consuming" $+          it "the original parse error (and state) is reported" $+            property $ \s -> do+              let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                  p = withRecovery (\e -> Left e <$ empty) empty+              grs  p s (`shouldFailWith` err posI mempty)+              grs' p s (`failsLeaving` s)+      it "works in complex situations too" $+        property $ \a' b' c' -> do+          let p :: MonadParsec Void String m => m (Either (ParseError Char Void) String)+              p = let g = count' 1 3 . char in v <$>+                withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'+              v (Right x) y = Right (x ++ y)+              v (Left  m) _ = Left m+              ma = if a < 3 then etok 'a' else mempty+              s = abcRow a b c+              [a,b,c] = getNonNegative <$> [a',b',c']+              f = flip shouldFailWith+              z = flip shouldParse+              r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))+                | a == 0 && b == 0 && c >  3 = f (err posI (utok 'c' <> etok 'a'))+                | a == 0 && b == 0           = f (err posI (utok 'c' <> etok 'a'))+                | a == 0 && b >  3           = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'a' <> etok 'c'))+                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'a' <> etok 'c'))+                | a == 0 &&           c >  3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))+                | a == 0                     = z (Left (err posI (utok 'b' <> etok 'a')))+                | a >  3                     = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))+                |           b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))+                |           b == 0 && c >  3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))+                |           b == 0           = z (Right s)+                | otherwise                  = f (err (posN a s) (utok 'b' <> etok 'c' <> ma))+          grs (p <* eof) s r++    describe "observing" $ do+      context "when inner parser succeeds consuming" $+        it "returns its result in Right" $+          property $ \a as -> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                p = observing (char a)+                s = a : as+            grs  p s (`shouldParse` Right a)+            grs' p s (`succeedsLeaving` as)+      context "when inner parser fails consuming" $ do+        it "returns its parse error in Left preserving state" $+          property $ \a b c as -> b /= c ==> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                p = observing (char a *> char b)+                s = a : c : as+            grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+            grs' p s (`succeedsLeaving` (c:as))+        it "does not create any hints" $+          property $ \a b c as -> b /= c ==> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                p = observing (char a *> char b) *> empty+                s = a : c : as+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+            grs' p s (`failsLeaving` (c:as))+      context "when inner parser succeeds without consuming" $+        it "returns its result in Right" $+          property $ \a s -> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                p = observing (return a)+            grs  p s (`shouldParse` Right a)+            grs' p s (`succeedsLeaving` s)+      context "when inner parser fails without consuming" $ do+        it "returns its parse error in Left preserving state" $+          property $ \s -> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) ())+                p = observing empty+            grs  p s (`shouldParse` Left (err posI mempty))+            grs' p s (`succeedsLeaving` s)+        it "creates correct hints" $+          property $ \a b as -> a /= b ==> do+            let p :: MonadParsec Void String m => m (Either (ParseError Char Void) Char)+                p = observing (char a) <* empty+                s = b : as+            grs  p s (`shouldFailWith` err posI (etok a))+            grs' p s (`failsLeaving` (b:as))++    describe "eof" $ do+      context "when input stream is empty" $+        it "succeeds" $+          grs eof "" (`shouldParse` ())+      context "when input stream is not empty" $+        it "signals correct error message" $+          property $ \a as -> do+            let s = a : as+            grs  eof s (`shouldFailWith` err posI (utok a <> eeof))+            grs' eof s (`failsLeaving` s)++    describe "token" $ do+      let f x = Tokens (nes x)+          testChar a x =+            if x == a+              then Right x+              else Left (pure (f x), E.singleton (f a))+      context "when supplied predicate is satisfied" $+        it "succeeds" $+          property $ \a as mtok -> do+            let p :: MonadParsec Void String m => m Char+                p = token (testChar a) mtok+                s = a : as+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` as)+      context "when supplied predicate is not satisfied" $+        it "signals correct parse error" $+          property $ \a b as mtok -> a /= b ==> do+            let p :: MonadParsec Void String m => m Char+                p = token (testChar b) mtok+                s = a : as+                us = pure (Tokens $ nes a)+                ps = E.singleton (Tokens $ nes b)+            grs  p s (`shouldFailWith` TrivialError posI us ps)+            grs' p s (`failsLeaving` s)+      context "when stream is empty" $+        it "signals correct parse error" $+          property $ \a mtok -> do+            let p :: MonadParsec Void String m => m Char+                p = token (testChar a) mtok+                us = pure EndOfInput+                ps = maybe E.empty (E.singleton . Tokens . nes) mtok+            grs p "" (`shouldFailWith` TrivialError posI us ps)++    describe "tokens" $ do+      context "when stream is prefixed with given string" $+        it "parses the string" $+          property $ \str s -> do+            let p :: MonadParsec Void String m => m String+                p = tokens (==) str+                s' = str ++ s+            grs  p s' (`shouldParse` str)+            grs' p s' (`succeedsLeaving` s)+      context "when stream is not prefixed with given string" $+        it "signals correct parse error" $+          property $ \str s -> not (str `isPrefixOf` s) ==> do+            let p :: MonadParsec Void String m => m String+                p = tokens (==) str+                z = take (length str) s+            grs  p s (`shouldFailWith` err posI (utoks z <> etoks str))+            grs' p s (`failsLeaving` s)++    describe "takeWhileP" $ do+      context "when stream is not empty" $+        it "consumes all matching tokens, zero or more" $+          property $ \s -> not (null s) ==> do+            let p :: MonadParsec Void String m => m String+                p = takeWhileP Nothing isLetter+                (z,zs) = DL.span isLetter s+            grs  p s (`shouldParse` z)+            grs' p s (`succeedsLeaving` zs)+      context "when stream is empty" $+        it "succeeds returning empty chunk" $ do+          let p :: MonadParsec Void String m => m String+              p = takeWhileP Nothing isLetter+          grs  p "" (`shouldParse` "")+          grs' p "" (`succeedsLeaving` "")+      context "with two takeWhileP in a row (testing hints)" $ do+        let p :: MonadParsec Void String m => m String+            p = do+              void $ takeWhileP (Just "foo") (== 'a')+              void $ takeWhileP (Just "bar") (== 'b')+              empty+        context "when the second one does not consume" $+          it "hints are combined properly" $ do+            let s = "aaa"+                pe = err (posN 3 s) (elabel "foo" <> elabel "bar")+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` "")+        context "when the second one consumes" $+          it "only hints of the second one affect parse error" $ do+            let s = "aaabbb"+                pe = err (posN 6 s) (elabel "bar")+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` "")+      context "without label (testing hints)" $+        it "there are no hints" $ do+          let p :: MonadParsec Void String m => m String+              p = takeWhileP Nothing (== 'a') <* empty+              s = "aaa"+          grs  p s (`shouldFailWith` err (posN 3 s) mempty)+          grs' p s (`failsLeaving` "")++    describe "takeWhile1P" $ do+      context "when stream is prefixed with matching tokens" $+        it "consumes the tokens" $+          property $ \s' -> do+            let p :: MonadParsec Void String m => m String+                p = takeWhile1P Nothing isLetter+                s = 'a' : s'+                (z,zs) = DL.span isLetter s+            grs  p s (`shouldParse` z)+            grs' p s (`succeedsLeaving` zs)+      context "when stream is not prefixed with at least one matching token" $+        it "signals correct parse error" $+          property $ \s' -> do+            let p :: MonadParsec Void String m => m String+                p = takeWhile1P (Just "foo") isLetter+                s = '3' : s'+                pe = err posI (utok '3' <> elabel "foo")+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` s)+      context "when stream is empty" $ do+        context "with label" $+          it "signals correct parse error" $ do+            let p :: MonadParsec Void String m => m String+                p = takeWhile1P (Just "foo") isLetter+                pe = err posI (ueof <> elabel "foo")+            grs  p "" (`shouldFailWith` pe)+            grs' p "" (`failsLeaving` "")+        context "without label" $+          it "signals correct parse error" $ do+            let p :: MonadParsec Void String m => m String+                p = takeWhile1P Nothing isLetter+                pe = err posI ueof+            grs  p "" (`shouldFailWith` pe)+            grs' p "" (`failsLeaving` "")+      context "with two takeWhile1P in a row (testing hints)" $ do+        let p :: MonadParsec Void String m => m String+            p = do+              void $ takeWhile1P (Just "foo") (== 'a')+              void $ takeWhile1P (Just "bar") (== 'b')+              empty+        context "when the second one does not consume" $+          it "hints are combined properly" $ do+            let s = "aaa"+                pe = err (posN 3 s) (ueof <> elabel "foo" <> elabel "bar")+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` "")+        context "when the second one consumes" $+          it "only hints of the second one affect parse error" $ do+            let s = "aaabbb"+                pe = err (posN 6 s) (elabel "bar")+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` "")+      context "without label (testing hints)" $+        it "there are no hints" $ do+          let p :: MonadParsec Void String m => m String+              p = takeWhile1P Nothing (== 'a') <* empty+              s = "aaa"+          grs  p s (`shouldFailWith` err (posN 3 s) mempty)+          grs' p s (`failsLeaving` "")++    describe "takeP" $ do+      context "when taking 0 tokens" $ do+        context "when stream is empty" $+          it "succeeds returning zero-length chunk" $ do+            let p :: MonadParsec Void String m => m String+                p = takeP Nothing 0+            grs  p "" (`shouldParse` "")+        context "when stream is not empty" $+          it "succeeds returning zero-length chunk" $+            property $ \s -> not (null s) ==> do+              let p :: MonadParsec Void String m => m String+                  p = takeP Nothing 0+              grs  p s (`shouldParse` "")+              grs' p s (`succeedsLeaving` s)+      context "when taking >0 tokens" $ do+        context "when stream is empty" $ do+          context "with label" $+            it "signals correct parse error" $+              property $ \(Positive n) -> do+                let p :: MonadParsec Void String m => m String+                    p = takeP (Just "foo") n+                    pe = err posI (ueof <> elabel "foo")+                grs  p "" (`shouldFailWith` pe)+                grs' p "" (`failsLeaving`   "")+          context "without label" $+            it "signals correct parse error" $+              property $ \(Positive n) -> do+                let p :: MonadParsec Void String m => m String+                    p = takeP Nothing n+                    pe = err posI ueof+                grs  p "" (`shouldFailWith` pe)+        context "when stream has not enough tokens" $+            it "signals correct parse error" $+              property $ \(Positive n) s -> length s < n && not (null s) ==> do+                let p :: MonadParsec Void String m => m String+                    p = takeP (Just "foo") n+                    pe = err (posN n s) (ueof <> elabel "foo")+                grs  p s (`shouldFailWith` pe)+                grs' p s (`failsLeaving` s)+        context "when stream has enough tokens" $+          it "succeeds returning the extracted tokens" $+            property $ \(Positive n) s -> length s >= n ==> do+              let p :: MonadParsec Void String m => m String+                  p = takeP (Just "foo") n+                  (s0,s1) = splitAt n s+              grs  p s (`shouldParse` s0)+              grs' p s (`succeedsLeaving` s1)+      context "when failing right after takeP (testing hints)" $+        it "there are no hints to influence the parse error" $+          property $ \(Positive n) s -> length s >= n ==> do+            let p :: MonadParsec Void String m => m String+                p = takeP (Just "foo") n <* empty+                pe = err (posN n s) mempty+            grs  p s (`shouldFailWith` pe)+            grs' p s (`failsLeaving` drop n s)++  describe "derivatives from primitive combinators" $ do++    describe "unexpected" $+      it "signals correct parse error" $+        property $ \item -> do+          let p :: MonadParsec Void String m => m ()+              p = void (unexpected item)+          grs p "" (`shouldFailWith` TrivialError posI (pure item) E.empty)++    describe "match" $+      it "return consumed tokens along with the result" $+        property $ \str -> do+          let p  = match (string str)+          prs  p str `shouldParse`     (str,str)+          prs' p str `succeedsLeaving` ""++    describe "region" $ do+      context "when inner parser succeeds" $+        it "has no effect" $+          property $ \st e n -> do+            let p :: Parser Int+                p = region (const e) (pure n)+            runParser' p st `shouldBe` (st, Right (n :: Int))+      context "when inner parser fails" $+        it "the given function is used on the parse error" $+          property $ \st' e pos' -> do+            let p :: Parsec Int String Int+                p = region f $+                  case e of+                    TrivialError _ us ps -> failure us ps+                    FancyError   _ xs    -> fancyFailure   xs+                f (TrivialError pos us ps) = FancyError+                  (max pos pos')+                  (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)+                f (FancyError pos xs) = FancyError+                  (max pos pos')+                  (E.singleton . ErrorCustom $ E.size xs)+                r = FancyError+                  (max (errorPos e) pos')+                  (E.singleton . ErrorCustom $+                    case e of+                      TrivialError _ us ps -> maybe 0 (const 1) us + E.size ps+                      FancyError   _ xs    -> E.size xs )+                finalPos = max (errorPos e) pos'+                st = st' { statePos = errorPos e }+            runParser' p st `shouldBe` (st { statePos = finalPos }, Left r)++    describe "takeRest" $+      it "returns rest of the input" $+        property $ \st@State {..} -> do+          let p :: Parser String+              p = takeRest+              (pos:|z) = statePos+              st' = st+                { stateInput = []+                , statePos   = advanceN+                    (Proxy :: Proxy String)+                    stateTabWidth+                    pos+                    stateInput :| z+                , stateTokensProcessed =+                    stateTokensProcessed + length stateInput }+          runParser' p st `shouldBe` (st', Right stateInput)++    describe "atEnd" $ do+      let p :: Parser Bool+          p = atEnd+      context "when stream is empty" $+        it "returns True" $+          prs p "" `shouldParse` True+      context "when stream is not empty" $+        it "returns False" $+          property $ \s -> not (null s) ==> do+            prs  p s `shouldParse` False+            prs' p s `succeedsLeaving` s++  describe "combinators for manipulating parser state" $ do++    describe "setInput and getInput" $+      it "sets input and gets it back" $+        property $ \s -> do+          let p = do+                st0 <- getInput+                guard (null st0)+                setInput s+                result <- string s+                st1 <- getInput+                guard (null st1)+                return result+          prs p "" `shouldParse` s++    describe "setPosition and getPosition" $+      it "sets position and gets it back" $+        property $ \st pos -> do+          let p :: Parser SourcePos+              p = setPosition pos >> getPosition+              f (State s (_:|xs) tp w) y = State s (y:|xs) tp w+          runParser' p st `shouldBe` (f st pos, Right pos)++    describe "pushPosition" $+      it "adds a layer to position stack and parser continues on that level" $+        property $ \st pos ->  do+          let p :: Parser ()+              p = pushPosition pos+          fst (runParser' p st) `shouldBe`+            st { statePos = NE.cons pos (statePos st) }++    describe "popPosition" $+      it "removes a layer from position stack" $+        property $ \st -> do+          let p :: Parser ()+              p = popPosition+              pos = statePos st+          fst (runParser' p st) `shouldBe`+            st { statePos = fromMaybe pos (snd (NE.uncons pos)) }++    describe "setTokensProcessed and getTokensProcessed" $+      it "sets number of processed toknes and gets it back" $+        property $ \tp -> do+          let p = setTokensProcessed tp >> getTokensProcessed+          prs p "" `shouldParse` tp++    describe "setTabWidth and getTabWidth" $+      it "sets tab width and gets it back" $+        property $ \w -> do+          let p = setTabWidth w >> getTabWidth+          prs p "" `shouldParse` w++    describe "setParserState and getParserState" $+      it "sets parser state and gets it back" $+        property $ \s1 s2 -> do+          let p :: MonadParsec Void String m => m (State String)+              p = do+                st <- getParserState+                guard (st == State s posI 0 defaultTabWidth)+                setParserState s1+                updateParserState (f s2)+                liftM2 const getParserState (setInput "")+              f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w+              s = ""+          grs p s (`shouldParse` f s2 s1)++  describe "running a parser" $ do+    describe "parseMaybe" $+      it "returns result on success and Nothing on failure" $+        property $ \s s' -> do+          let p = string s' :: Parser String+          parseMaybe p s `shouldBe`+            if s == s' then Just s else Nothing++    describe "runParser'" $+      it "works" $+        property $ \st s -> do+          let p = string s+          runParser' p st `shouldBe` emulateStrParsing st s++    describe "runParserT'" $+      it "works" $+        property $ \st s -> do+          let p = string s+          runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s++  describe "MonadParsec instance of ReaderT" $ do++    describe "try" $+      it "generally works" $+        property $ \pre ch1 ch2 -> do+          let s1 = pre : [ch1]+              s2 = pre : [ch2]+              getS1 = asks fst+              getS2 = asks snd+              p = try (g =<< getS1) <|> (g =<< getS2)+              g = sequence . fmap char+              s = [pre]+          prs (runReaderT p (s1, s2)) s `shouldFailWith`+            err (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \a' b' c' -> do+          let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar+              [a,b,c] = getNonNegative <$> [a',b',c']+              s = abcRow a b c+          if b > 0 || c > 0+            then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'+            else prs (runReaderT p 'a') s `shouldFailWith`+                   err (posN a s) (ueof <> etok 'a')++  describe "MonadParsec instance of lazy StateT" $ do++    describe "(<|>)" $+      it "generally works" $+        property $ \n -> do+          let p = L.put n >>+                ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get+          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "lookAhead" $+      it "generally works" $+        property $ \n -> do+          let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get+          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \n -> do+          let p = do+                L.put n+                let notEof = notFollowedBy (L.modify (* 2) >> eof)+                some (try (anyChar <* notEof)) <* char 'x'+          prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect state" $+          property $ \m n -> do+            let p = do+                  L.put m+                  observing (L.modify (+ n))+            prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)+      context "when inner parser fails" $+        it "cannot affect state" $+          property $ \m n -> do+            let p = do+                  L.put m+                  observing (L.modify (+ n) <* empty)+            prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)++  describe "MonadParsec instance of strict StateT" $ do++    describe "(<|>)" $+      it "generally works" $+        property $ \n -> do+          let p = S.put n >>+                ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get+          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "lookAhead" $+      it "generally works" $+        property $ \n -> do+          let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get+          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \n -> do+          let p = do+                S.put n+                let notEof = notFollowedBy (S.modify (* 2) >> eof)+                some (try (anyChar <* notEof)) <* char 'x'+          prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect state" $+          property $ \m n -> do+            let p = do+                  S.put m+                  observing (L.modify (+ n))+            prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)+      context "when inner parser fails" $+        it "cannot affect state" $+          property $ \m n -> do+            let p = do+                  S.put m+                  observing (L.modify (+ n) <* empty)+            prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)++  describe "MonadParsec instance of lazy WriterT" $ do++    it "generally works" $+      property $ \pre post -> do+        let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x+            loggedEof    = eof >> L.tell "EOF"+            p = do+              L.tell pre+              cs <- L.censor (fmap toUpper) $+                some (try (loggedLetter <* notFollowedBy loggedEof))+              L.tell post+              void loggedLetter+              return cs+        prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")++    describe "lookAhead" $+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = lookAhead (L.tell [w])+          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++    describe "notFollowedBy" $+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = notFollowedBy (L.tell [w] <* char 'a')+          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect log" $+          property $ \n -> do+            let p = observing (L.tell $ Sum n)+            prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)+      context "when inner parser fails" $+        it "cannot affect log" $+          property $ \n -> do+            let p = observing (L.tell (Sum n) <* empty)+            prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)++  describe "MonadParsec instance of strict WriterT" $ do++    it "generally works" $+      property $ \pre post -> do+        let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x+            loggedEof    = eof >> S.tell "EOF"+            p = do+              S.tell pre+              cs <- L.censor (fmap toUpper) $+                some (try (loggedLetter <* notFollowedBy loggedEof))+              S.tell post+              void loggedLetter+              return cs+        prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")++    describe "lookAhead" $+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = lookAhead (S.tell [w])+          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++    describe "notFollowedBy" $+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = notFollowedBy (S.tell [w] <* char 'a')+          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect log" $+          property $ \n -> do+            let p = observing (S.tell $ Sum n)+            prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)+      context "when inner parser fails" $+        it "cannot affect log" $+          property $ \n -> do+            let p = observing (S.tell (Sum n) <* empty)+            prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)++  describe "MonadParsec instance of lazy RWST" $ do++    describe "label" $+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = label "a" ((,) <$> L.ask <*> L.get)+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "try" $+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = try ((,) <$> L.ask <*> L.get)+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "lookAhead" $ do+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = lookAhead ((,) <$> L.ask <*> L.get)+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = lookAhead (L.tell [w])+          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+            ((), 0, mempty :: [Int])+      it "does not allow to influence state outside it" $+        property $ \s0 s1 -> (s0 /= s1) ==> do+          let p = lookAhead (L.put s1)+          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+            ((), s0, mempty :: [Int])++    describe "notFollowedBy" $ do+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = notFollowedBy (L.tell [w] <* char 'a')+          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+            ((), 0, mempty :: [Int])+      it "does not allow to influence state outside it" $+        property $ \s0 s1 -> (s0 /= s1) ==> do+          let p = notFollowedBy (L.put s1 <* char 'a')+          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+            ((), s0, mempty :: [Int])++    describe "withRecovery" $ do+      it "allows main parser to access reader context and state inside it" $+        property $ \r s -> do+          let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])+      it "allows recovering parser to access reader context and state inside it" $+        property $ \r s -> do+          let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "observing" $ do+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = observing ((,) <$> L.ask <*> L.get)+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            (Right (r, s), s, mempty :: [Int])+      context "when the inner parser fails" $+        it "backtracks state" $+          property $ \r s0 s1 -> (s0 /= s1) ==> do+            let p = observing (L.put s1 <* empty)+            prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`+              (Left (err posI mempty), s0, mempty :: [Int])++  describe "MonadParsec instance of strict RWST" $ do++    describe "label" $+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = label "a" ((,) <$> S.ask <*> S.get)+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "try" $+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = try ((,) <$> S.ask <*> S.get)+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "lookAhead" $ do+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = lookAhead ((,) <$> S.ask <*> S.get)+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = lookAhead (S.tell [w])+          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+            ((), 0, mempty :: [Int])+      it "does not allow to influence state outside it" $+        property $ \s0 s1 -> (s0 /= s1) ==> do+          let p = lookAhead (S.put s1)+          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+            ((), s0, mempty :: [Int])++    describe "notFollowedBy" $ do+      it "discards what writer tells inside it" $+        property $ \w -> do+          let p = notFollowedBy (S.tell [w] <* char 'a')+          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+            ((), 0, mempty :: [Int])+      it "does not allow to influence state outside it" $+        property $ \s0 s1 -> (s0 /= s1) ==> do+          let p = notFollowedBy (S.put s1 <* char 'a')+          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+            ((), s0, mempty :: [Int])++    describe "withRecovery" $ do+      it "allows main parser to access reader context and state inside it" $+        property $ \r s -> do+          let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])+      it "allows recovering parser to access reader context and state inside it" $+        property $ \r s -> do+          let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            ((r, s), s, mempty :: [Int])++    describe "observing" $ do+      it "allows to access reader context and state inside it" $+        property $ \r s -> do+          let p = observing ((,) <$> S.ask <*> S.get)+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+            (Right (r, s), s, mempty :: [Int])+      context "when the inner parser fails" $+        it "backtracks state" $+          property $ \r s0 s1 -> (s0 /= s1) ==> do+            let p = observing (S.put s1 <* empty)+            prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`+              (Left (err posI mempty), s0, mempty :: [Int])++  describe "dbg" $ do+    -- NOTE We don't test properties here to avoid flood of debugging output+    -- when the test runs.+    context "when inner parser succeeds consuming input" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "char" (char 'a')+            s = "ab"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` "b"+      it "its hints are preserved" $ do+        let p = dbg "many chars" (many (char 'a')) <* empty+            s = "abcd"+        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (etok 'a')+        prs' p s `failsLeaving` "bcd"+    context "when inner parser fails consuming input" $+      it "has no effect on how parser works" $ do+        let p = dbg "chars" (char 'a' *> char 'c')+            s = "abc"+        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')+        prs' p s `failsLeaving` "bc"+    context "when inner parser succeeds without consuming" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "return" (return 'a')+            s = "abc"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` s+      it "its hints are preserved" $ do+        let p = dbg "many chars" (many (char 'a')) <* empty+            s = "bcd"+        prs  p s `shouldFailWith` err posI (etok 'a')+        prs' p s `failsLeaving` "bcd"+    context "when inner parser fails without consuming" $+      it "has no effect on how parser works" $ do+        let p = dbg "empty" (void empty)+            s = "abc"+        prs  p s `shouldFailWith` err posI mempty+        prs' p s `failsLeaving` s++----------------------------------------------------------------------------+-- Helpers++-- | This data type represents tokens in custom input stream.++data Span = Span+  { spanStart :: SourcePos+  , spanEnd   :: SourcePos+  , spanBody  :: NonEmpty Char+  } deriving (Eq, Ord, Show)++instance Stream [Span] where+  type Token [Span] = Span+  type Tokens [Span] = [Span]+  tokenToChunk Proxy = pure+  tokensToChunk Proxy = id+  chunkToTokens Proxy = id+  chunkLength Proxy = length+  chunkEmpty Proxy = null+  positionAt1 Proxy _ (Span start _ _) = start+  positionAtN Proxy pos [] = pos+  positionAtN Proxy _ (Span start _ _:_) = start+  advance1 Proxy _ _ (Span _ end _) = end+  advanceN Proxy _ pos [] = pos+  advanceN Proxy _ _ ts =+    let Span _ end _ = last ts in end+  take1_ [] = Nothing+  take1_ (t:ts) = Just (t, ts)+  takeN_ n s+    | n <= 0   = Just ([], s)+    | null s   = Nothing+    | otherwise = Just (splitAt n s)+  takeWhile_ = DL.span++instance Arbitrary Span where+  arbitrary = do+    start <- arbitrary+    end   <- arbitrary `suchThat` (> start)+    Span start end <$>+      (NE.fromList . getNonEmpty <$> arbitrary)++instance ShowToken Span where+  showTokens ts = concat (NE.toList . spanBody <$> ts)++type CustomParser = Parsec Void [Span]++pSpan :: Span -> CustomParser Span+pSpan span = token testToken (Just span)+  where+    f = Tokens . nes+    testToken x =+      if spanBody x == spanBody span+        then Right span+        else Left (pure (f x), E.singleton (f span))++incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])+incCoincidence st ts = do+  n <- getSmall <$> arbitrary+  let (pre, post) = splitAt n (stateInput st)+      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts+  return st { stateInput = pre' ++ post }++emulateStrParsing+  :: State String+  -> String+  -> (State String, Either (ParseError Char Void) String)+emulateStrParsing st@(State i (pos:|z) tp w) s =+  if s == take l i+    then ( State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w+         , Right s )+    else ( st+         , Left $ err (pos:|z) (etoks s <> utoks (take l i)) )+  where+    l = length s