diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,44 @@ +## Megaparsec 4.2.0 + +* Made `newPos` constructor and other functions in `Text.Megaparsec.Pos` + smarter. Now it's impossible to create `SourcePos` with non-positive line + number or column number. Unfortunately we cannot use `Numeric.Natural` + because we need to support older versions of `base`. + +* `ParseError` is now a monoid. `mergeError` is used as `mappend`. + +* Added functions `addErrorMessages` and `newErrorMessages` to add several + messages to existing error and to construct error with several attached + messages respectively. + +* `parseFromFile` now lives in `Text.Megaparsec.Prim`. Previously we had 5 + nearly identical definitions of the function, varying only in + type-specific `readFile` function. Now the problem is solved by + introduction of `StorableStream` type class. All supported stream types + are instances of the class out of box and thus we have polymorphic version + of `parseFromFile`. + +* `ParseError` is now instance of `Exception` (and `Typeable`). + +* Introduced `runParser'` and `runParserT'` functions that take and return + parser state. This makes it possible to partially parse input, resume + parsing, specify non-standard initial textual position, etc. + +* Introduced `failure` function that allows to fail with arbitrary + collection of messages. `unexpected` is now defined in terms of + `failure`. One consequence of this design decision is that `failure` is + now method of `MonadParsec`, while `unexpected` is not. + +* Removed deprecated combinators from `Text.Megaparsec.Combinator`: + + * `chainl` + * `chainl1` + * `chainr` + * `chainr1` + +* `number` parser in `Text.Megaparsec.Lexer` now can be used with `signed` + combinator to parse either signed `Integer` or signed `Double`. + ## Megaparsec 4.1.1 * Fixed bug in implementation of `sepEndBy` and `sepEndBy1` and removed diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -9,17 +9,18 @@ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -This software is provided by the copyright holders "as is" and any express or -implied warranties, including, but not limited to, the implied warranties of -merchantability and fitness for a particular purpose are disclaimed. In no -event shall the copyright holders be liable for any direct, indirect, -incidental, special, exemplary, or consequential damages (including, but not -limited to, procurement of substitute goods or services; loss of use, data, -or profits; or business interruption) however caused and on any theory of -liability, whether in contract, strict liability, or tort (including -negligence or otherwise) arising in any way out of the use of this software, -even if advised of the possibility of such damage. +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,282 @@ +# Megaparsec + +[![License FreeBSD](https://img.shields.io/badge/license-FreeBSD-brightgreen.svg)](http://opensource.org/licenses/BSD-2-Clause) +[![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) +[![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) +[![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/megaparsec/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/megaparsec?branch=master) + +* [Features](#features) + * [Core features](#core-features) + * [Character parsing](#character-parsing) + * [Permutation parsing](#permutation-parsing) + * [Expression parsing](#expression-parsing) + * [Lexer](#lexer) +* [Documentation](#documentation) +* [Tutorials](#tutorials) +* [Comparison with other solutions](#comparison-with-other-solutions) + * [Megaparsec and Attoparsec](#megaparsec-and-attoparsec) + * [Megaparsec and Parsec](#megaparsec-and-parsec) + * [Megaparsec and Parsers](#megaparsec-and-parsers) +* [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 +written by Daan Leijen. + +## Features + +This project provides flexible solutions to satisfy common parsing +needs. The section describes them shortly. If you're looking for +comprehensive documentation, see the +[section about documentation](#documentation). + +### Core features + +The package is built around `MonadParsec`, a MTL-style monad +transformer. All tools and features work with any instance of +`MonadParsec`. You can achieve various effects combining monad transformers, +i.e. building monad stack. Since most common monad transformers like +`WriterT`, `StateT`, `ReaderT` and others are instances of `MonadParsec`, +you can wrap `ParsecT` *in* these monads, achieving, for example, +backtracking state. + +On the other hand `ParsecT` is instance of many type classes as well. The +most useful ones are `Monad`, `Applicative`, `Alternative`, and +`MonadParsec`. + +The module +[`Text.Megaparsec.Combinator`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Combinator.html) +(its functions are included in `Text.Megaparsec`) contains traditional, +general combinators that work with any instance of `Alternative` and some +even with instances of `Applicative`. + +Role of `Monad`, `Applicative`, and `Alternative` should be obvious, so +let's enumerate methods of `MonadParsec` type class. The class represents +core, basic functions of Megaparsec parsing. The rest of library is built +via combination of these primitives: + +* `failure` allows to fail with arbitrary collection of messages. + +* `label` allows to add a “label” to any parser, so when it fails the user will + see the label in the error message where “expected” items are enumerated. + +* `hidden` hides any parser from error messages altogether, this is + officially recommended way to hide things, prefer it to the `label ""` + approach. + +* `try` enables backtracking in parsing. + +* `lookAhead` allows to parse something without consuming input. + +* `notFollowedBy` succeeds when its argument fails, it does not consume + input. + +* `eof` only succeeds at the end of input. + +* `token` is used to parse single token. + +* `tokens` makes it easy to parse several tokens in a row. + +* `getParserState` returns full parser state. + +* `updateParserState` applies given function on parser state. + +This list of core function is longer than in some other libraries. Our goal +was easy and readable implementation of functionality provided by every such +primitive, not minimal number of them. You can read the comprehensive +description of every primitive function in [Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html). + +Megaparsec can currently work with the following types of input stream: + +* `String` = `[Char]` + +* `ByteString` (strict and lazy) + +* `Text` (strict and lazy) + +### Character parsing + +Megaparsec has decent support for Unicode-aware character parsing. Functions +for character parsing live in [`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) (they all are +included in `Text.Megaparsec`). The functions can be divided into several +categories: + +* *Simple parsers* — parsers that parse certain character or several + characters of the same kind. This includes `newline`, `crlf`, `eol`, + `tab`, and `space`. + +* *Parsers corresponding to categories of characters* parse single character + that belongs to certain category of characters, for example: + `controlChar`, `spaceChar`, `upperChar`, `lowerChar`, `printChar`, + `digitChar`, and others. + +* *General parsers* that allow you to parse a single character you specify + or one of given characters, or any character except for given ones, or + character satisfying given predicate. Case-insensitive versions of the + parsers are available. + +* *Parsers for sequences of characters* parse strings. These are more + efficient and provide better error messages than other approaches most + programmers can come up with. Case-sensitive `string` parser is available + as well as case-insensitive `string'`. + +### Permutation parsing + +For those who are interested in parsing of permutation phrases, there is +[`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html). You have to import the module explicitly, it's not +included in the `Text.Megaparsec` module. + +### Expression parsing + +Megaparsec has a solution for parsing of expressions. Take a look at +[`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html). You have to import the module explicitly, it's not +included in the `Text.Megaparsec`. + +Given a table of operators that describes their fixity and precedence, you +can construct a parser that will parse any expression involving the +operators. See documentation for comprehensive description of how it works. + +### Lexer + +[`Text.Megaparsec.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Lexer.html) +is a module that should help you write your lexer. If you have used `Parsec` +in the past, this module “fixes” its particularly inflexible +`Text.Parsec.Token`. + +`Text.Megaparsec.Lexer` is intended to be imported qualified, it's not +included in `Text.Megaparsec`. The module doesn't impose how you should +write your parser, but certain approaches may be more elegant than +others. An especially important theme is parsing of white space, comments, +and indentation. + +The design of the module allows you quickly solve simple tasks and doesn't +get in your way when you want to implemented something less standard. + +## Documentation + +Megaparsec is well-documented. All functions and data-types are thoroughly +described. We pay attention to avoid outdated info or unclear phrases in our +documentation. See the [current version of Megaparsec documentation on +Hackage](https://hackage.haskell.org/package/megaparsec) for yourself. + +## Tutorials + +You can visit [site of the project](https://mrkkrp.github.io/megaparsec/) +which has several tutorials that should help you to start with your parsing +tasks. The site also has instructions and tips for Parsec users who decide +to switch. + +## Comparison with other solutions + +There are quite a few libraries that can be used for parsing in Haskell, +let's compare Megaparsec with some of them. + +### Megaparsec and Attoparsec + +[Attoparsec](https://github.com/bos/attoparsec) is another prominent Haskell +library for parsing. Although the both libraries deal with parsing, it's +usually easy to decide which you will need in particular project: + +* *Attoparsec* is much faster but not that feature-rich. It should be used + when you want to process large amounts of data where performance matter + more than quality of error messages. + +* *Megaparsec* is good for parsing of source code or other human-readable + texts. It has better error messages and it's implemented as monad + transformer. + +So, if you work with something human-readable where size of input data is +usually not huge, just go with Megaparsec, otherwise Attoparsec may be a +better choice. + +### Megaparsec and Parsec + +Since Megaparsec is a fork of Parsec, it's necessary to list main +differences between the two libraries: + +* Better error messages. We test our error messages using dense QuickCheck + tests. Good error messages are just as important for us as correct return + values of our parsers. Megaparsec will be especially useful if you write + compiler or interpreter for some language. + +* Some quirks and “buggy features” (as well as plain bugs) of original + Parsec are fixed. There is no undocumented surprising stuff in Megaparsec. + +* Better support for Unicode parsing in `Text.Megaparsec.Char`. + +* Megaparsec has more powerful combinators and can parse languages where + indentation matters. + +* Comprehensive QuickCheck test suite covering nearly 100% of our code. + +* We have benchmarks to detect performance regressions. + +* Better documentation, with 100% of functions covered, without typos and + obsolete information, with working examples. Megaparsec's documentation is + well-structured and doesn't contain things useless to end users. + +* Megaparsec's code is clearer and doesn't contain “magic” found in original + Parsec. + +If you want to see a detailed change log, `CHANGELOG.md` may be helpful. + +To be honest Parsec's development has seemingly stagnated. It has no test +suite (only three per-bug tests), and all its releases beginning from +version 3.1.2 (according or its change log) were about introducing and +fixing regressions. Parsec is old and somewhat famous in Haskell community, +so we understand there will be some kind of inertia, but we advise you use +Megaparsec from now on because it solves many problems of original Parsec +project. If you think you still have a reason to use original Parsec, open +an issue. + +### Megaparsec and Parsers + +There is [Parsers](https://hackage.haskell.org/package/parsers) package, +which is great. You can use it with Megaparsec or Parsec, but consider the +following: + +* It depends on *both* Attoparsec and Parsec, which means you always grab + useless code installing it. This is ridiculous, by the way, because this + package is supposed to be useful for parser builders, so they can write + basic core functionality and get the rest “for free”. But with these + useful functions you get two more parsers as dependencies. + +* It currently has a bug in definition of `lookAhead` for various monad + transformers like `StateT`, etc. which is visible when you create + backtracking state via monad stack, not via built-in features. See #27. + +We intended to use Parsers library in Megaparsec at some point, but aside +from already mentioned flaws the library has different conventions for +naming of things, different set of “core” functions, etc., different +approach to lexer. So it didn't happen, Megaparsec has minimal dependencies, +it is feature-rich and self-contained. + +## Authors + +The project was started and is currently maintained by Mark Karpov. You can +find complete list of contributors in `AUTHORS.md` file in official +repository of the project. Thanks to all the people who propose features and +ideas, although they are not in `AUTHORS.md`, without them Megaparsec would +not be that good. + +## Contribution + +Issues (bugs, feature requests or otherwise feedback) may be reported in +[the GitHub issue tracker for this project](https://github.com/mrkkrp/megaparsec/issues). + +Pull requests are also welcome (and yes, they will get attention and will be +merged quickly if they are good, we are progressive folks). + +If you want to write a tutorial to be hosted on Megaparsec's site, open an +issue or pull request [here](https://github.com/mrkkrp/megaparsec-site). + +## License + +Copyright © 2015 Megaparsec contributors
+Copyright © 2007 Paolo Martini
+Copyright © 1999–2000 Daan Leijen + +Distributed under FreeBSD license. diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -31,8 +31,7 @@ -- > -- import Text.Megaparsec.Text.Lazy -- -- As you can see the second import depends on data type you want to use as --- input stream. It just defines useful type-synonym @Parser@ and --- @parseFromFile@ function. +-- input stream. It just defines useful type-synonym @Parser@. -- -- Megaparsec is capable of a lot. Apart from this standard functionality -- you can parse permutation phrases with "Text.Megaparsec.Perm" and even @@ -44,10 +43,13 @@ Parsec , ParsecT , runParser + , runParser' , runParserT + , runParserT' , parse , parseMaybe , parseTest + , parseFromFile -- * Combinators , (A.<|>) -- $assocbo @@ -58,6 +60,7 @@ , A.optional -- $optional , unexpected + , failure , () , label , hidden @@ -82,11 +85,6 @@ , sepEndBy1 , skipMany , skipSome - -- Deprecated combinators - , chainl - , chainl1 - , chainr - , chainr1 -- * Character parsing , newline , crlf @@ -136,6 +134,7 @@ , sourceColumn -- * Low-level operations , Stream (..) + , StorableStream (..) , State (..) , getInput , setInput diff --git a/Text/Megaparsec/ByteString.hs b/Text/Megaparsec/ByteString.hs --- a/Text/Megaparsec/ByteString.hs +++ b/Text/Megaparsec/ByteString.hs @@ -2,40 +2,22 @@ -- Module : Text.Megaparsec.ByteString -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- --- Convenience definitions for working with 'C.ByteString'. +-- Convenience definitions for working with 'B.ByteString'. -module Text.Megaparsec.ByteString - ( Parser - , parseFromFile ) -where +module Text.Megaparsec.ByteString (Parser) where -import Text.Megaparsec.Error import Text.Megaparsec.Prim - -import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString as B -- | Different modules corresponding to various types of streams (@String@, -- @Text@, @ByteString@) define it differently, so user can use “abstract” -- @Parser@ type and easily change it by importing different “type --- modules”. This one is for strict bytestrings. - -type Parser = Parsec C.ByteString - --- | @parseFromFile p filePath@ runs a strict bytestring parser @p@ on the --- input read from @filePath@ using 'ByteString.Char8.readFile'. Returns --- either a 'ParseError' ('Left') or a value of type @a@ ('Right'). --- --- > main = do --- > result <- parseFromFile numbers "digits.txt" --- > case result of --- > Left err -> print err --- > Right xs -> print (sum xs) +-- modules”. This one is for strict byte-strings. -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname = runParser p fname `fmap` C.readFile fname +type Parser = Parsec B.ByteString diff --git a/Text/Megaparsec/ByteString/Lazy.hs b/Text/Megaparsec/ByteString/Lazy.hs --- a/Text/Megaparsec/ByteString/Lazy.hs +++ b/Text/Megaparsec/ByteString/Lazy.hs @@ -2,40 +2,22 @@ -- Module : Text.Megaparsec.ByteString.Lazy -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- --- Convenience definitions for working with lazy 'C.ByteString'. +-- Convenience definitions for working with lazy 'B.ByteString'. -module Text.Megaparsec.ByteString.Lazy - ( Parser - , parseFromFile ) -where +module Text.Megaparsec.ByteString.Lazy (Parser) where -import Text.Megaparsec.Error import Text.Megaparsec.Prim - -import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.ByteString.Lazy as B -- | Different modules corresponding to various types of streams (@String@, -- @Text@, @ByteString@) define it differently, so user can use “abstract” -- @Parser@ type and easily change it by importing different “type --- modules”. This one is for lazy bytestrings. - -type Parser = Parsec C.ByteString - --- | @parseFromFile p filePath@ runs a lazy bytestring parser @p@ on the --- input read from @filePath@ using 'ByteString.Lazy.Char8.readFile'. --- Returns either a 'ParseError' ('Left') or a value of type @a@ ('Right'). --- --- > main = do --- > result <- parseFromFile numbers "digits.txt" --- > case result of --- > Left err -> print err --- > Right xs -> print (sum xs) +-- modules”. This one is for lazy byte-strings. -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname = runParser p fname `fmap` C.readFile fname +type Parser = Parsec B.ByteString diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs --- a/Text/Megaparsec/Char.hs +++ b/Text/Megaparsec/Char.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental diff --git a/Text/Megaparsec/Combinator.hs b/Text/Megaparsec/Combinator.hs --- a/Text/Megaparsec/Combinator.hs +++ b/Text/Megaparsec/Combinator.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -27,12 +27,7 @@ , sepEndBy , sepEndBy1 , skipMany - , skipSome - -- Deprecated combinators - , chainl - , chainl1 - , chainr - , chainr1 ) + , skipSome ) where import Control.Applicative @@ -179,60 +174,3 @@ skipSome :: Alternative m => m a -> m () skipSome p = void $ some p {-# INLINE skipSome #-} - --- Deprecated combinators - --- | @chainl p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned by --- @p@. If there are zero occurrences of @p@, the value @x@ is returned. - -{-# DEPRECATED chainl "Use \"Text.Megaparsec.Expr\" instead." #-} - -chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainl p op x = chainl1 p op <|> pure x -{-# INLINE chainl #-} - --- | @chainl1 p op@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned by --- @p@. This parser can for example be used to eliminate left recursion --- which typically occurs in expression grammars. --- --- Consider using "Text.Megaparsec.Expr" instead. - -{-# DEPRECATED chainl1 "Use \"Text.Megaparsec.Expr\" instead." #-} - -chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan - where scan = flip id <$> p <*> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id -{-# INLINE chainl1 #-} - --- | @chainr p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned by --- @p@. If there are no occurrences of @p@, the value @x@ is returned. --- --- Consider using "Text.Megaparsec.Expr" instead. - -{-# DEPRECATED chainr "Use \"Text.Megaparsec.Expr\" instead." #-} - -chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainr p op x = chainr1 p op <|> pure x -{-# INLINE chainr #-} - --- | @chainr1 p op@ parses /one/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned by --- @p@. --- --- Consider using "Text.Megaparsec.Expr" instead. - -{-# DEPRECATED chainr1 "Use \"Text.Megaparsec.Expr\" instead." #-} - -chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = flip id <$> p <*> rst - rst = (flip <$> op <*> scan) <|> pure id -{-# INLINE chainr1 #-} diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -20,30 +20,27 @@ , errorMessages , errorIsUnknown , newErrorMessage + , newErrorMessages , newErrorUnknown , addErrorMessage + , addErrorMessages , setErrorMessage , setErrorPos , mergeError , showMessages ) where -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif +import Control.Exception (Exception) import Data.List (intercalate) import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) import Text.Megaparsec.Pos #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Foldable (foldMap) -#endif -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t +import Data.Monoid #endif -- | This data type represents parse error messages. There are three kinds @@ -98,42 +95,58 @@ errorPos :: !SourcePos -- | Extract the list of error messages from 'ParseError'. , errorMessages :: [Message] } - deriving Eq + deriving (Eq, Typeable) instance Show ParseError where show e = show (errorPos e) ++ ":\n" ++ showMessages (errorMessages e) +instance Monoid ParseError where + mempty = newErrorUnknown (initialPos "") + mappend = mergeError + +instance Exception ParseError + -- | Test whether given 'ParseError' has associated collection of error -- messages. Return @True@ if it has none and @False@ otherwise. errorIsUnknown :: ParseError -> Bool errorIsUnknown (ParseError _ ms) = null ms --- Creation of parse errors +-- | @newErrorMessage m pos@ creates 'ParseError' with message @m@ and +-- associated position @pos@. If message @m@ has empty message string, it +-- won't be included. +newErrorMessage :: Message -> SourcePos -> ParseError +newErrorMessage m = newErrorMessages [m] + +-- | @newErrorMessages ms pos@ creates 'ParseError' with messages @ms@ and +-- associated position @pos@. + +newErrorMessages :: [Message] -> SourcePos -> ParseError +newErrorMessages ms pos = addErrorMessages ms $ newErrorUnknown pos + -- | @newErrorUnknown pos@ creates 'ParseError' without any associated -- message but with specified position @pos@. newErrorUnknown :: SourcePos -> ParseError newErrorUnknown pos = ParseError pos [] --- | @newErrorMessage m pos@ creates 'ParseError' with message @m@ and --- associated position @pos@. If message @m@ has empty message string, it --- won't be included. - -newErrorMessage :: Message -> SourcePos -> ParseError -newErrorMessage m pos = ParseError pos $ bool [m] [] (badMessage m) - -- | @addErrorMessage m err@ returns @err@ with message @m@ added. This -- function makes sure that list of messages is always sorted and doesn't -- contain duplicates or messages with empty message strings. addErrorMessage :: Message -> ParseError -> ParseError addErrorMessage m (ParseError pos ms) = - ParseError pos $ bool (pre ++ [m] ++ post) ms (badMessage m) + ParseError pos $ if badMessage m then ms else pre ++ [m] ++ post where pre = filter (< m) ms post = filter (> m) ms +-- | @addErrorMessages ms err@ returns @err@ with messages @ms@ added. The +-- function is defined in terms of 'addErrorMessage'. + +addErrorMessages :: [Message] -> ParseError -> ParseError +addErrorMessages ms err = foldr addErrorMessage err ms + -- | @setErrorMessage m err@ returns @err@ with message @m@ added. This -- function also deletes all existing error messages that were created with -- the same constructor as @m@. If message @m@ has empty message string, the @@ -142,9 +155,9 @@ setErrorMessage :: Message -> ParseError -> ParseError setErrorMessage m (ParseError pos ms) = - bool (addErrorMessage m pe) pe (badMessage m) - where pe = ParseError pos xs - xs = filter ((/= fromEnum m) . fromEnum) ms + if badMessage m then err else addErrorMessage m err + where err = ParseError pos xs + xs = filter ((/= fromEnum m) . fromEnum) ms -- | @setErrorPos pos err@ returns 'ParseError' identical to @err@, but with -- position @pos@. @@ -162,7 +175,7 @@ mergeError e1@(ParseError pos1 _) e2@(ParseError pos2 ms2) = case pos1 `compare` pos2 of LT -> e2 - EQ -> foldr addErrorMessage e1 ms2 + EQ -> addErrorMessages ms2 e1 GT -> e1 -- | @showMessages ms@ transforms list of error messages @ms@ into diff --git a/Text/Megaparsec/Expr.hs b/Text/Megaparsec/Expr.hs --- a/Text/Megaparsec/Expr.hs +++ b/Text/Megaparsec/Expr.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -37,15 +37,23 @@ -- @term@ with operators from @table@, taking the associativity and -- precedence specified in @table@ into account. -- --- @table@ is a list of @[Operator s u m a]@ lists. The list is ordered in +-- @table@ is a list of @[Operator m a]@ lists. The list is ordered in -- descending precedence. All operators in one list have the same precedence --- (but may have a different associativity). +-- (but may have different associativity). -- --- Prefix and postfix operators of the same precedence can only occur once --- (i.e. @--2@ is not allowed if @-@ is prefix negate). Prefix and postfix --- operators of the same precedence associate to the left (i.e. if @++@ is --- postfix increment, than @-2++@ equals @-1@, not @-3@). +-- Prefix and postfix operators of the same precedence associate to the left +-- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). -- +-- Unary operators of the same precedence can only occur once (i.e. @--2@ is +-- not allowed if @-@ is prefix negate). If you need to parse several prefix +-- or postfix operators in a row, (like C pointers — @**i@) you can use this +-- approach: +-- +-- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp +-- +-- This is not done by default because in some cases you don't want to allow +-- repeating prefix or postfix operators. +-- -- @makeExprParser@ takes care of all the complexity involved in building an -- expression parser. Here is an example of an expression parser that -- handles prefix signs, postfix increment and basic arithmetic: @@ -93,7 +101,7 @@ pre <- option id (hidden prefix) x <- term post <- option id (hidden postfix) - return $ post (pre x) + return . post . pre $ x -- | @pInfixN op p x@ parses non-associative infix operator @op@, then term -- with parser @p@, then returns result of the operator application on @x@ diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs --- a/Text/Megaparsec/Lexer.hs +++ b/Text/Megaparsec/Lexer.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -30,6 +30,7 @@ -- * Character and string literals , charLiteral -- * Numbers + , Signed (..) , integer , decimal , hexadecimal @@ -43,6 +44,8 @@ import Control.Monad (void) import Data.Char (readLitChar) import Data.Maybe (listToMaybe) +import Prelude hiding (negate) +import qualified Prelude import Text.Megaparsec.Combinator import Text.Megaparsec.Pos @@ -184,6 +187,26 @@ -- Numbers +-- | This type class abstracts the concept of signed number in context of +-- this module. This is especially useful when you want to compose 'signed' +-- and 'number'. + +class Signed a where + + -- | Unary negation. + + negate :: a -> a + +instance Signed Integer where + negate = Prelude.negate + +instance Signed Double where + negate = Prelude.negate + +instance (Signed l, Signed r) => Signed (Either l r) where + negate (Left x) = Left $ negate x + negate (Right x) = Right $ negate x + -- | Parse an integer without sign in decimal representation (according to -- format of integer literals described in Haskell report). -- @@ -275,11 +298,11 @@ -- > integer = lexeme L.integer -- > signedInteger = L.signed spaceConsumer integer -signed :: (MonadParsec s m Char, Num a) => m () -> m a -> m a +signed :: (MonadParsec s m Char, Signed 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 s m Char, Num a) => m (a -> a) +sign :: (MonadParsec s m Char, Signed a) => m (a -> a) sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate) diff --git a/Text/Megaparsec/Perm.hs b/Text/Megaparsec/Perm.hs --- a/Text/Megaparsec/Perm.hs +++ b/Text/Megaparsec/Perm.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs --- a/Text/Megaparsec/Pos.hs +++ b/Text/Megaparsec/Pos.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -16,19 +16,20 @@ , sourceName , sourceLine , sourceColumn + , InvalidTextualPosition (..) + , newPos + , initialPos , incSourceLine , incSourceColumn , setSourceName , setSourceLine , setSourceColumn - , newPos - , initialPos , updatePosChar , updatePosString , defaultTabWidth ) where -import Data.Data (Data) +import Control.Exception (Exception, throw) import Data.List (foldl') import Data.Typeable (Typeable) @@ -44,7 +45,7 @@ , sourceLine :: !Int -- | Extract the column number from a source position. , sourceColumn :: !Int } - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord) instance Show SourcePos where show (SourcePos n l c) @@ -52,11 +53,36 @@ | otherwise = n ++ ":" ++ showLC where showLC = show l ++ ":" ++ show c +-- | This exception is thrown when some action on 'SourcePos' is performed +-- that would make column number or line number inside this data structure +-- non-positive. +-- +-- The 'InvalidTextualPosition' structure includes in order: +-- +-- * name of file +-- * line number (possibly non-positive value) +-- * column number (possibly non-positive value) + +data InvalidTextualPosition = + InvalidTextualPosition String Int Int + deriving (Eq, Show, Typeable) + +instance Exception InvalidTextualPosition + -- | Create a new 'SourcePos' with the given source name, line number and -- column number. +-- +-- If line number of column number is not positive, 'InvalidTextualPosition' +-- will be thrown. -newPos :: String -> Int -> Int -> SourcePos -newPos = SourcePos +newPos :: String -- ^ File name + -> Int -- ^ Line number, minimum is 1 + -> Int -- ^ Column number, minimum is 1 + -> SourcePos +newPos n l c = + if l < 1 || c < 1 + then throw $ InvalidTextualPosition n l c + else SourcePos n l c -- | Create a new 'SourcePos' with the given source name, and line number -- and column number set to 1, the upper left. @@ -64,30 +90,34 @@ initialPos :: String -> SourcePos initialPos name = newPos name 1 1 --- | Increment the line number of a source position. +-- | Increment the line number of a source position. If resulting line +-- number is not positive, 'InvalidTextualPosition' will be thrown. incSourceLine :: SourcePos -> Int -> SourcePos -incSourceLine (SourcePos n l c) d = SourcePos n (l + d) c +incSourceLine (SourcePos n l c) d = newPos n (l + d) c --- | Increments the column number of a source position. +-- | Increment the column number of a source position. If resulting column +-- number is not positive, 'InvalidTextualPosition' will be thrown. incSourceColumn :: SourcePos -> Int -> SourcePos -incSourceColumn (SourcePos n l c) d = SourcePos n l (c + d) +incSourceColumn (SourcePos n l c) d = newPos n l (c + d) -- | Set the name of the source. setSourceName :: SourcePos -> String -> SourcePos -setSourceName (SourcePos _ l c) n = SourcePos n l c +setSourceName (SourcePos _ l c) n = newPos n l c --- | Set the line number of a source position. +-- | Set the line number of a source position. If the line number is not +-- positive, 'InvalidTextualPosition' will be thrown. setSourceLine :: SourcePos -> Int -> SourcePos -setSourceLine (SourcePos n _ c) l = SourcePos n l c +setSourceLine (SourcePos n _ c) l = newPos n l c --- | Set the column number of a source position. +-- | Set the column number of a source position. If the line number is not +-- positive, 'InvalidTextualPosition' will be thrown. setSourceColumn :: SourcePos -> Int -> SourcePos -setSourceColumn (SourcePos n l _) = SourcePos n l +setSourceColumn (SourcePos n l _) c = newPos n l c -- | Update a source position given a character. The first argument -- specifies tab width. If the character is a newline (\'\\n\') the line diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs --- a/Text/Megaparsec/Prim.hs +++ b/Text/Megaparsec/Prim.hs @@ -3,7 +3,7 @@ -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -17,11 +17,13 @@ ( -- * Used data-types State (..) , Stream (..) + , StorableStream (..) , Parsec , ParsecT -- * Primitive combinators , MonadParsec (..) , () + , unexpected -- * Parser state combinators , getInput , setInput @@ -32,17 +34,15 @@ , setParserState -- * Running parser , runParser + , runParser' , runParserT + , runParserT' , parse , parseMaybe - , parseTest ) + , parseTest + , parseFromFile ) where -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif -import Data.Monoid - import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class @@ -51,6 +51,7 @@ import Control.Monad.State.Class hiding (state) import Control.Monad.Trans import Control.Monad.Trans.Identity +import Data.Monoid import qualified Control.Applicative as A import qualified Control.Monad.Trans.Reader as L import qualified Control.Monad.Trans.State.Lazy as L @@ -61,19 +62,16 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.ShowToken #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*)) -#endif -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t +import Control.Applicative ((<$>), (<*), pure) #endif -- | This is Megaparsec state, it's parametrized over stream type @s@. @@ -84,53 +82,33 @@ , stateTabWidth :: !Int } deriving (Show, Eq) --- | An instance of @Stream s t@ has stream type @s@, and token type @t@ --- determined by the stream. - -class (ShowToken t, ShowToken [t]) => Stream s t | s -> t where - uncons :: s -> Maybe (t, s) - -instance (ShowToken t, ShowToken [t]) => Stream [t] t where - uncons [] = Nothing - uncons (t:ts) = Just (t, ts) - {-# INLINE uncons #-} - -instance Stream B.ByteString Char where - uncons = B.uncons - {-# INLINE uncons #-} - -instance Stream BL.ByteString Char where - uncons = BL.uncons - {-# INLINE uncons #-} - -instance Stream T.Text Char where - uncons = T.uncons - {-# INLINE uncons #-} +-- | All information available after parsing. This includes consumption of +-- input, success (with return value) or failure (with parse error), parser +-- state at the end of parsing. +-- +-- See also: 'Consumption', 'Result'. -instance Stream TL.Text Char where - uncons = TL.uncons - {-# INLINE uncons #-} +data Reply s a = Reply !(State s) Consumption (Result a) -- | This data structure represents an aspect of result of parser's -- work. The two constructors have the following meaning: -- --- * @Consumed@ is a wrapper for result when some part of input stream --- was consumed. --- * @Empty@ is a wrapper for result when no input was consumed. +-- * @Consumed@ means that some part of input stream was consumed. +-- * @Virgin@ means that no input was consumed. -- --- See also: 'Reply'. +-- See also: 'Result', 'Reply'. -data Consumed a = Consumed a | Empty !a +data Consumption = Consumed | Virgin -- | This data structure represents an aspect of result of parser's -- work. The two constructors have the following meaning: -- --- * @Ok@ for successfully run parser. --- * @Error@ for failed parser. +-- * @OK@ means that parser succeeded. +-- * @Error@ means that parser failed. -- --- See also: 'Consumed'. +-- See also: 'Consumption', 'Reply'. -data Reply s a = Ok a !(State s) | Error ParseError +data Result a = OK a | Error ParseError -- | 'Hints' represent collection of strings to be included into 'ParserError' -- as “expected” messages when a parser fails without consuming input right @@ -162,8 +140,7 @@ -- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. withHints :: Hints -> (ParseError -> m b) -> ParseError -> m b -withHints (Hints xs) c = c . addHints - where addHints err = foldr addErrorMessage err (Expected <$> concat xs) +withHints (Hints xs) c = c . addErrorMessages (Expected <$> concat xs) -- | @accHints hs c@ results in “OK” continuation that will add given hints -- @hs@ to third argument of original continuation @c@. @@ -180,6 +157,58 @@ refreshLastHint (Hints (_:xs)) "" = Hints xs refreshLastHint (Hints (_:xs)) l = Hints ([l]:xs) +-- | An instance of @Stream s t@ has stream type @s@, and token type @t@ +-- determined by the stream. + +class (ShowToken t, ShowToken [t]) => Stream s t | s -> t where + uncons :: s -> Maybe (t, s) + +instance (ShowToken t, ShowToken [t]) => Stream [t] t where + uncons [] = Nothing + uncons (t:ts) = Just (t, ts) + {-# INLINE uncons #-} + +instance Stream B.ByteString Char where + uncons = B.uncons + {-# INLINE uncons #-} + +instance Stream BL.ByteString Char where + uncons = BL.uncons + {-# INLINE uncons #-} + +instance Stream T.Text Char where + uncons = T.uncons + {-# INLINE uncons #-} + +instance Stream TL.Text Char where + uncons = TL.uncons + {-# INLINE uncons #-} + +-- | @StorableStream@ abstracts ability of some streams to be stored in a +-- file. This is used by polymorphic function 'readFromFile'. + +class Stream s t => StorableStream s t where + + -- | @fromFile filename@ returns action that will try to read contents of + -- file named @filename@. + + fromFile :: FilePath -> IO s + +instance StorableStream String Char where + fromFile = readFile + +instance StorableStream B.ByteString Char where + fromFile = B.readFile + +instance StorableStream BL.ByteString Char where + fromFile = BL.readFile + +instance StorableStream T.Text Char where + fromFile = T.readFile + +instance StorableStream TL.Text Char where + fromFile = TL.readFile + -- If you're reading this, you may be interested in how Megaparsec works on -- lower level. That's quite simple. 'ParsecT' is a wrapper around function -- that takes five arguments: @@ -258,9 +287,9 @@ in unParser p s (walk []) cerr manyErr (errToHints $ eok [] s) manyErr :: a -manyErr = error - "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser \ - \that accepts an empty string." +manyErr = error $ concat + [ "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser" + , " that accepts an empty string." ] instance Monad (ParsecT s m) where return = pReturn @@ -287,20 +316,18 @@ -- | Low-level creation of the ParsecT type. -mkPT :: Monad m => (State s -> m (Consumed (m (Reply s a)))) -> ParsecT s m a +mkPT :: Monad m => (State s -> m (Reply s a)) -> ParsecT s m a mkPT k = ParsecT $ \s cok cerr eok eerr -> do - cons <- k s - case cons of - Consumed mrep -> do - rep <- mrep - case rep of - Ok x s' -> cok x s' mempty - Error err -> cerr err - Empty mrep -> do - rep <- mrep - case rep of - Ok x s' -> eok x s' mempty - Error err -> eerr err + (Reply s' consumption result) <- k s + case consumption of + Consumed -> do + case result of + OK x -> cok x s' mempty + Error e -> cerr e + Virgin -> do + case result of + OK x -> eok x s' mempty + Error e -> eerr e instance MonadIO m => MonadIO (ParsecT s m) where liftIO = lift . liftIO @@ -315,15 +342,15 @@ instance MonadCont m => MonadCont (ParsecT s m) where callCC f = mkPT $ \s -> - callCC $ \c -> - runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s - where pack s a = Empty $ return (Ok a s) + callCC $ \c -> + runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s + where pack s a = Reply s Virgin (OK a) instance MonadError e m => MonadError e (ParsecT s m) where throwError = lift . throwError p `catchError` h = mkPT $ \s -> - runParsecT p s `catchError` \e -> - runParsecT (h e) s + runParsecT p s `catchError` \e -> + runParsecT (h e) s instance MonadPlus (ParsecT s m) where mzero = pZero @@ -335,9 +362,9 @@ pPlus :: ParsecT s m a -> ParsecT s m a -> ParsecT s m a pPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err = - let ncerr err' = cerr (mergeError err' err) + let ncerr err' = cerr (err' <> err) neok x s' hs = eok x s' (toHints err <> hs) - neerr err' = eerr (mergeError err' err) + neerr err' = eerr (err' <> err) in unParser n s cok ncerr neok neerr in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} @@ -352,13 +379,13 @@ class (A.Alternative m, Monad m, Stream s t) => MonadParsec s m t | m -> s t where - -- | The parser @unexpected msg@ always fails with an unexpected error - -- message @msg@ without consuming any input. + -- | The most general way to stop parsing and report 'ParseError'. -- - -- The parsers 'fail', ('') and 'unexpected' are the three parsers used - -- to generate error messages. Of these, only ('') is commonly used. + -- 'unexpected' is defined in terms of the function: + -- + -- > unexpected = failure . pure . Unexpected - unexpected :: String -> m a + failure :: [Message] -> 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 @@ -467,7 +494,7 @@ updateParserState :: (State s -> State s) -> m () instance Stream s t => MonadParsec s (ParsecT s m) t where - unexpected = pUnexpected + failure = pFailure label = pLabel try = pTry lookAhead = pLookAhead @@ -478,9 +505,9 @@ getParserState = pGetParserState updateParserState = pUpdateParserState -pUnexpected :: String -> ParsecT s m a -pUnexpected msg = ParsecT $ \(State _ pos _) _ _ _ eerr -> - eerr $ newErrorMessage (Unexpected msg) pos +pFailure :: [Message] -> ParsecT s m a +pFailure msgs = ParsecT $ \(State _ pos _) _ _ _ eerr -> + eerr $ newErrorMessages msgs pos pLabel :: String -> ParsecT s m a -> ParsecT s m a pLabel l p = ParsecT $ \s cok cerr eok eerr -> @@ -525,7 +552,7 @@ Nothing -> eerr $ unexpectedErr eoi pos Just (c,cs) -> case test c of - Left ms -> eerr $ foldr addErrorMessage (newErrorUnknown pos) ms + Left ms -> eerr $ addErrorMessages ms (newErrorUnknown pos) Right x -> let newpos = nextpos w pos c newstate = State cs newpos w in seq newpos $ seq newstate $ cok x newstate mempty @@ -545,7 +572,7 @@ in cok (reverse is) s' mempty walk (t:ts) is rs = let errorCont = if null is then eerr else cerr - what = bool (showToken $ reverse is) eoi (null is) + what = if null is then eoi else showToken $ reverse is in case uncons rs of Nothing -> errorCont . errExpect $ what Just (x,xs) @@ -569,6 +596,15 @@ () :: MonadParsec s m t => m a -> String -> m a () = flip label +-- | The parser @unexpected msg@ always fails with an unexpected error +-- message @msg@ without consuming any input. +-- +-- The parsers 'fail', 'label' and 'unexpected' are the three parsers used +-- to generate error messages. Of these, only 'label' is commonly used. + +unexpected :: MonadParsec s m t => String -> m a +unexpected = failure . pure . Unexpected + unexpectedErr :: String -> SourcePos -> ParseError unexpectedErr msg = newErrorMessage (Unexpected msg) @@ -634,7 +670,7 @@ parse :: Stream s t => Parsec s a -- ^ Parser to run - -> String -- ^ Name of source file, included in error messages + -> String -- ^ Name of source file -> s -- ^ Input for parser -> Either ParseError a parse = runParser @@ -661,61 +697,103 @@ parseTest :: (Stream s t, Show a) => Parsec s a -> s -> IO () parseTest p input = case parse p "" input of - Left err -> print err - Right x -> print x + Left e -> print e + Right x -> print x --- | The most general way to run a parser over the 'Identity' monad. --- @runParser p file input@ runs parser @p@ on the input list of tokens +-- | @runParser p file input@ runs parser @p@ on the input list of tokens -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns either a 'ParseError' -- ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file -runParser :: Stream s t => Parsec s a -> String -> s -> Either ParseError a -runParser p name s = runIdentity $ runParserT p name s +runParser :: Stream s t + => Parsec s a -- ^ Parser to run + -> String -- ^ Name of source file + -> s -- ^ Input for parser + -> Either ParseError a +runParser p name s = snd $ runParser' p (initialState name s) --- | The most general way to run a parser. @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 return --- either a 'ParseError' ('Left') or a value of type @a@ ('Right'). +-- | 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. +runParser' :: Stream s t + => Parsec s a -- ^ Parser to run + -> State s -- ^ Initial state + -> (State s, Either ParseError 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, Stream s t) => ParsecT s m a -> String -> s -> m (Either ParseError a) -runParserT p name s = do - res <- runParsecT p $ State s (initialPos name) defaultTabWidth - r <- parserReply res - case r of - Ok x _ -> return $ Right x - Error err -> return $ Left err - where parserReply res = - case res of - Consumed r -> r - Empty r -> r +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. + +runParserT' :: (Monad m, Stream s t) + => ParsecT s m a -- ^ Parser to run + -> State s -- ^ Initial state + -> m (State s, Either ParseError a) +runParserT' p s = do + (Reply s' _ result) <- runParsecT p s + case result of + OK x -> return $ (s', Right x) + Error e -> return $ (s', Left e) + +-- | Given name of source file and input construct initial state for parser. + +initialState :: Stream s t => String -> s -> State s +initialState name s = State s (initialPos name) defaultTabWidth + -- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' -- are built upon this. runParsecT :: Monad m - => ParsecT s m a -> State s -> m (Consumed (m (Reply s a))) + => ParsecT s m a -- ^ Parser to run + -> State s -- ^ Initial state + -> m (Reply s a) runParsecT p s = unParser p s cok cerr eok eerr - where cok a s' _ = return . Consumed . return $ Ok a s' - cerr err = return . Consumed . return $ Error err - eok a s' _ = return . Empty . return $ Ok a s' - eerr err = return . Empty . return $ Error err + where cok a s' _ = return $ Reply s' Consumed (OK a) + cerr err = return $ Reply s Consumed (Error err) + eok a s' _ = return $ Reply s' Virgin (OK a) + eerr err = return $ Reply s Virgin (Error err) +-- | @parseFromFile p filename@ runs parser @p@ on the input read from +-- @filename@. Returns either a 'ParseError' ('Left') or a value of type @a@ +-- ('Right'). +-- +-- > main = do +-- > result <- parseFromFile numbers "digits.txt" +-- > case result of +-- > Left err -> print err +-- > Right xs -> print $ sum xs + +parseFromFile :: StorableStream s t + => Parsec s a -- ^ Parser to run + -> FilePath -- ^ Name of file to parse + -> IO (Either ParseError a) +parseFromFile p filename = runParser p filename <$> fromFile filename + -- Instances of 'MonadParsec' instance (MonadPlus m, MonadParsec s m t) => MonadParsec s (L.StateT e m) t where - label n (L.StateT m) = L.StateT $ \s -> label n (m s) + 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) - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts @@ -724,13 +802,13 @@ instance (MonadPlus m, MonadParsec s m t) => MonadParsec s (S.StateT e m) t where - label n (S.StateT m) = S.StateT $ \s -> label n (m s) + 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) - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts @@ -739,11 +817,11 @@ instance (MonadPlus m, MonadParsec s m t) => MonadParsec s (L.ReaderT e m) t where - label n (L.ReaderT m) = L.ReaderT $ \s -> label n (m s) + label n (L.ReaderT m) = L.ReaderT $ label n . m try (L.ReaderT m) = L.ReaderT $ try . m - lookAhead (L.ReaderT m) = L.ReaderT $ \s -> lookAhead (m s) + lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts @@ -758,7 +836,7 @@ (,mempty) . fst <$> lookAhead m notFollowedBy (L.WriterT m) = L.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts @@ -773,7 +851,7 @@ (,mempty) . fst <$> lookAhead m notFollowedBy (S.WriterT m) = S.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts @@ -786,7 +864,7 @@ try = IdentityT . try . runIdentityT lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - unexpected = lift . unexpected + failure = lift . failure eof = lift eof token f e = lift $ token f e tokens f e ts = lift $ tokens f e ts diff --git a/Text/Megaparsec/ShowToken.hs b/Text/Megaparsec/ShowToken.hs --- a/Text/Megaparsec/ShowToken.hs +++ b/Text/Megaparsec/ShowToken.hs @@ -1,7 +1,7 @@ -- | -- Module : Text.Megaparsec.ShowToken -- Copyright : © 2015 Megaparsec contributors --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental diff --git a/Text/Megaparsec/String.hs b/Text/Megaparsec/String.hs --- a/Text/Megaparsec/String.hs +++ b/Text/Megaparsec/String.hs @@ -2,7 +2,7 @@ -- Module : Text.Megaparsec.String -- Copyright : © 2015 Megaparsec contributors -- © 2007 Paolo Martini --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -10,12 +10,8 @@ -- -- Make Strings an instance of 'Stream' with 'Char' token type. -module Text.Megaparsec.String - ( Parser - , parseFromFile ) -where +module Text.Megaparsec.String (Parser) where -import Text.Megaparsec.Error import Text.Megaparsec.Prim -- | Different modules corresponding to various types of streams (@String@, @@ -24,16 +20,3 @@ -- modules”. This one is for strings. type Parser = Parsec String - --- | @parseFromFile p filePath@ runs a string parser @p@ on the --- input read from @filePath@ using 'Prelude.readFile'. Returns either a --- 'ParseError' ('Left') or a value of type @a@ ('Right'). --- --- > main = do --- > result <- parseFromFile numbers "digits.txt" --- > case result of --- > Left err -> print err --- > Right xs -> print (sum xs) - -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname = runParser p fname `fmap` readFile fname diff --git a/Text/Megaparsec/Text.hs b/Text/Megaparsec/Text.hs --- a/Text/Megaparsec/Text.hs +++ b/Text/Megaparsec/Text.hs @@ -2,7 +2,7 @@ -- Module : Text.Megaparsec.Text -- Copyright : © 2015 Megaparsec contributors -- © 2011 Antoine Latter --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -10,15 +10,10 @@ -- -- Convenience definitions for working with 'T.Text'. -module Text.Megaparsec.Text - ( Parser - , parseFromFile ) -where +module Text.Megaparsec.Text (Parser) where -import Text.Megaparsec.Error import Text.Megaparsec.Prim import qualified Data.Text as T -import qualified Data.Text.IO as T -- | Different modules corresponding to various types of streams (@String@, -- @Text@, @ByteString@) define it differently, so user can use “abstract” @@ -26,16 +21,3 @@ -- modules”. This one is for strict text. type Parser = Parsec T.Text - --- | @parseFromFile p filePath@ runs a lazy text parser @p@ on the --- input read from @filePath@ using 'Data.Text.IO.readFile'. Returns either --- a 'ParseError' ('Left') or a value of type @a@ ('Right'). --- --- > main = do --- > result <- parseFromFile numbers "digits.txt" --- > case result of --- > Left err -> print err --- > Right xs -> print (sum xs) - -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname = runParser p fname `fmap` T.readFile fname diff --git a/Text/Megaparsec/Text/Lazy.hs b/Text/Megaparsec/Text/Lazy.hs --- a/Text/Megaparsec/Text/Lazy.hs +++ b/Text/Megaparsec/Text/Lazy.hs @@ -2,7 +2,7 @@ -- Module : Text.Megaparsec.Text.Lazy -- Copyright : © 2015 Megaparsec contributors -- © 2011 Antoine Latter --- License : BSD3 +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental @@ -10,15 +10,10 @@ -- -- Convenience definitions for working with lazy 'T.Text'. -module Text.Megaparsec.Text.Lazy - ( Parser - , parseFromFile ) -where +module Text.Megaparsec.Text.Lazy (Parser) where -import Text.Megaparsec.Error import Text.Megaparsec.Prim import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T -- | Different modules corresponding to various types of streams (@String@, -- @Text@, @ByteString@) define it differently, so user can use “abstract” @@ -26,16 +21,3 @@ -- modules”. This one is for lazy text. type Parser = Parsec T.Text - --- | @parseFromFile p filePath@ runs a lazy text parser @p@ on the --- input read from @filePath@ using 'Data.Text.Lazy.IO.readFile'. Returns --- either a 'ParseError' ('Left') or a value of type @a@ ('Right'). --- --- > main = do --- > result <- parseFromFile numbers "digits.txt" --- > case result of --- > Left err -> print err --- > Right xs -> print (sum xs) - -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname = runParser p fname `fmap` T.readFile fname diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,6 +1,6 @@ -- -*- Mode: Haskell; -*- -- --- Criterion benchmarks for Megaparsec, main module. +-- Criterion benchmarks for Megaparsec. -- -- Copyright © 2015 Megaparsec contributors -- @@ -15,17 +15,17 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. {-# LANGUAGE CPP #-} @@ -74,11 +74,12 @@ #endif -- benchSteps and benchSize control the benchmark test points + benchSteps :: Int #if BENCHMARK_STEPS -benchSteps = BENCHMARK_STEPS +benchSteps = BENCHMARK_STEPS #else -benchSteps = 5 +benchSteps = 5 #endif benchSize :: Int #if BENCHMARK_SIZE @@ -88,7 +89,6 @@ #endif -- End of configuration parameters - main :: IO () main = defaultMain benchmarks diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -15,22 +15,22 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. name: megaparsec -version: 4.1.1 +version: 4.2.0 cabal-version: >= 1.10 -license: BSD3 +license: BSD2 license-file: LICENSE.md author: Megaparsec contributors, Paolo Martini , @@ -47,7 +47,9 @@ This is industrial-strength monadic parser combinator library. Megaparsec is a fork of Parsec library originally written by Daan Leijen. -extra-source-files: AUTHORS.md, CHANGELOG.md +extra-source-files: AUTHORS.md + , CHANGELOG.md + , README.md library build-depends: base >= 4.6 && < 5 @@ -97,7 +99,7 @@ , Bugs.Bug39 , Util build-depends: base >= 4.6 && < 5 - , megaparsec >= 4.1.1 + , megaparsec >= 4.2 , HUnit >= 1.2 && < 1.4 , test-framework >= 0.6 && < 1 , test-framework-hunit >= 0.2 && < 0.4 @@ -110,7 +112,7 @@ main-is: Main.hs hs-source-dirs: tests type: exitcode-stdio-1.0 - ghc-options: -O2 -Wall -rtsopts + ghc-options: -O2 -Wall other-modules: Char , Combinator , Error @@ -121,7 +123,7 @@ , Prim , Util build-depends: base >= 4.6 && < 5 - , megaparsec >= 4.1.1 + , megaparsec >= 4.2 , mtl == 2.* , transformers == 0.4.* , QuickCheck >= 2.4 && < 3 @@ -137,9 +139,9 @@ main-is: Main.hs hs-source-dirs: benchmarks type: exitcode-stdio-1.0 - ghc-options: -O2 -Wall -rtsopts + ghc-options: -O2 -Wall build-depends: base >= 4.6 && < 5 - , megaparsec >= 4.1.1 + , megaparsec >= 4.2 , criterion >= 0.6.2.1 && < 1.2 , text >= 1.2 && < 2 , bytestring >= 0.10 && < 2 diff --git a/tests/Char.hs b/tests/Char.hs --- a/tests/Char.hs +++ b/tests/Char.hs @@ -15,17 +15,17 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. {-# OPTIONS -fno-warn-orphans #-} @@ -245,9 +245,7 @@ -- | Randomly change the case in the given string. fuzzyCase :: String -> Gen String -fuzzyCase s = do - b <- vector (length s) - return $ zipWith f s b +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 diff --git a/tests/Combinator.hs b/tests/Combinator.hs --- a/tests/Combinator.hs +++ b/tests/Combinator.hs @@ -15,17 +15,17 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Combinator (tests) where @@ -67,7 +67,7 @@ b = length $ takeWhile (== c) post r | b > 0 = posErr (length pre + n + b) s $ exStr post : if length post == b - then [uneEof] + then [uneEof, exCh c] else [uneCh (post !! b), exCh c] | otherwise = Right z z = replicate n c diff --git a/tests/Error.hs b/tests/Error.hs --- a/tests/Error.hs +++ b/tests/Error.hs @@ -15,26 +15,24 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. {-# OPTIONS -fno-warn-orphans #-} module Error (tests) where -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif import Data.List (isPrefixOf, isInfixOf) +import Data.Monoid ((<>)) import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -46,26 +44,25 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) -#endif -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t +import Data.Monoid (mempty) #endif tests :: Test tests = testGroup "Parse errors" - [ testProperty "extracting message string" prop_messageString - , testProperty "creation of new error messages" prop_newErrorMessage + [ testProperty "monoid left identity" prop_monoid_left_id + , testProperty "monoid right identity" prop_monoid_right_id + , testProperty "monoid associativity" prop_monoid_assoc + , testProperty "extraction of message string" prop_messageString + , testProperty "creation of new error messages" prop_newErrorMessage , testProperty "messages are always well-formed" prop_wellFormedMessages - , testProperty "copying of error positions" prop_parseErrorCopy - , testProperty "setting of error position" prop_setErrorPos - , testProperty "addition of error message" prop_addErrorMessage - , testProperty "setting of error message" prop_setErrorMessage - , testProperty "position of merged error" prop_mergeErrorPos - , testProperty "messages of merged error" prop_mergeErrorMsgs - , testProperty "position of error is visible" prop_visiblePos - , testProperty "message components are visible" prop_visibleMsgs ] + , testProperty "copying of error positions" prop_parseErrorCopy + , testProperty "setting of error position" prop_setErrorPos + , testProperty "addition of error message" prop_addErrorMessage + , testProperty "setting of error message" prop_setErrorMessage + , testProperty "position of merged error" prop_mergeErrorPos + , testProperty "messages of merged error" prop_mergeErrorMsgs + , testProperty "position of error is visible" prop_visiblePos + , testProperty "message components are visible" prop_visibleMsgs ] instance Arbitrary Message where arbitrary = ($) <$> elements constructors <*> arbitrary @@ -73,11 +70,20 @@ instance Arbitrary ParseError where arbitrary = do - ms <- listOf arbitrary - pe <- oneof [ newErrorUnknown <$> arbitrary - , newErrorMessage <$> arbitrary <*> arbitrary ] - return $ foldr addErrorMessage pe ms + ms <- listOf arbitrary + err <- oneof [ newErrorUnknown <$> arbitrary + , newErrorMessage <$> arbitrary <*> arbitrary ] + return $ addErrorMessages ms err +prop_monoid_left_id :: ParseError -> Bool +prop_monoid_left_id x = mempty <> x == x + +prop_monoid_right_id :: ParseError -> Bool +prop_monoid_right_id x = x <> mempty == x + +prop_monoid_assoc :: ParseError -> ParseError -> ParseError -> Bool +prop_monoid_assoc x y z = (x <> y) <> z == x <> (y <> z) + prop_messageString :: Message -> Bool prop_messageString m@(Unexpected s) = s == messageString m prop_messageString m@(Expected s) = s == messageString m @@ -86,10 +92,10 @@ prop_newErrorMessage :: Message -> SourcePos -> Bool prop_newErrorMessage msg pos = added && errorPos new == pos where new = newErrorMessage msg pos - added = errorMessages new == bool [msg] [] (badMessage msg) + added = errorMessages new == if badMessage msg then [] else [msg] prop_wellFormedMessages :: ParseError -> Bool -prop_wellFormedMessages err = wellFormed $ errorMessages err +prop_wellFormedMessages = wellFormed . errorMessages prop_parseErrorCopy :: ParseError -> Bool prop_parseErrorCopy err = @@ -131,13 +137,16 @@ prop_visiblePos err = show (errorPos err) `isPrefixOf` show err prop_visibleMsgs :: ParseError -> Bool -prop_visibleMsgs err = all (`isInfixOf` shown) (errorMessages err >>= f) +prop_visibleMsgs err = if null msgs + then "unknown" `isInfixOf` shown + else all (`isInfixOf` shown) (msgs >>= f) where shown = show err + msgs = errorMessages err f (Unexpected s) = ["unexpected", s] - f (Expected s) = ["expecting", s] + f (Expected s) = ["expecting", s] f (Message s) = [s] --- | @iwellFormed xs@ checks that list @xs@ is sorted and contains no +-- | @wellFormed xs@ checks that list @xs@ is sorted and contains no -- duplicates and no empty messages. wellFormed :: [Message] -> Bool diff --git a/tests/Expr.hs b/tests/Expr.hs --- a/tests/Expr.hs +++ b/tests/Expr.hs @@ -15,24 +15,22 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Expr (tests) where import Control.Applicative (some, (<|>)) -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif +import Data.Char (isDigit, digitToInt) import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -49,15 +47,12 @@ import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) #endif -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t -#endif - tests :: Test tests = testGroup "Expression parsers" - [ testProperty "correctness of expression parser" prop_correctness ] + [ testProperty "correctness of expression parser" prop_correctness + , testProperty "error message on empty input" prop_empty_error + , testProperty "error message on missing term" prop_missing_term + , testProperty "error message on missing op" prop_missing_op ] -- Algebraic structures to build abstract syntax tree of our expression. @@ -100,13 +95,13 @@ showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y showGT :: Node -> Node -> String -showGT parent node = bool showNode showCmp (node > parent) node +showGT parent node = (if node > parent then showCmp else showNode) node showGE :: Node -> Node -> String -showGE parent node = bool showNode showCmp (node >= parent) node +showGE parent node = (if node >= parent then showCmp else showNode) node showCmp :: Node -> String -showCmp node = bool inParens showNode (fromEnum node == 0) node +showCmp node = (if fromEnum node == 0 then showNode else inParens) node inParens :: Node -> String inParens x = "(" ++ showNode x ++ ")" @@ -121,9 +116,9 @@ arbitraryN1 :: Int -> Gen Node arbitraryN1 n = - frequency [ (1, Neg <$> arbitraryN2 n) - , (1, Fac <$> arbitraryN2 n) - , (7, arbitraryN2 n)] + frequency [ (1, Neg <$> arbitraryN2 n) + , (1, Fac <$> arbitraryN2 n) + , (7, arbitraryN2 n)] arbitraryN2 :: Int -> Gen Node arbitraryN2 0 = Val . getNonNegative <$> arbitrary @@ -168,3 +163,24 @@ prop_correctness :: Node -> Property prop_correctness node = checkParser expr (Right node) (showNode node) + +prop_empty_error :: Property +prop_empty_error = checkParser expr r s + where r = posErr 0 s [uneEof, exSpec "term"] + s = "" + +prop_missing_term :: Char -> Property +prop_missing_term c = checkParser expr r s + where r | c `elem` "-(" = posErr 1 s [uneEof, exSpec "term"] + | isDigit c = Right . Val . fromIntegral . digitToInt $ c + | otherwise = posErr 0 s [uneCh c, exSpec "term"] + s = pure c + +prop_missing_op :: Node -> Node -> Property +prop_missing_op a b = checkParser expr r s + where a' = inParens a + c = s !! n + n = succ $ length a' + r | c == '-' = Right $ Sub a b + | otherwise = posErr n s $ [uneCh c, exEof, exSpec "operator"] + s = a' ++ " " ++ inParens b diff --git a/tests/Lexer.hs b/tests/Lexer.hs --- a/tests/Lexer.hs +++ b/tests/Lexer.hs @@ -15,25 +15,22 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Lexer (tests) where import Control.Applicative (empty) import Control.Monad (void) -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif import Data.Char ( readLitChar , showLitChar @@ -61,27 +58,24 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>)) #endif -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t -#endif tests :: Test tests = testGroup "Lexer" - [ testProperty "space combinator" prop_space - , testProperty "symbol combinator" prop_symbol - , testProperty "symbol' combinator" prop_symbol' - , testProperty "indentGuard combinator" prop_indentGuard - , testProperty "charLiteral" prop_charLiteral - , testProperty "integer" prop_integer - , testProperty "decimal" prop_decimal - , testProperty "hexadecimal" prop_hexadecimal - , testProperty "octal" prop_octal - , testProperty "float 0" prop_float_0 - , testProperty "float 1" prop_float_1 - , testProperty "number" prop_number - , testProperty "signed" prop_signed ] + [ testProperty "space combinator" prop_space + , testProperty "symbol combinator" prop_symbol + , testProperty "symbol' combinator" prop_symbol' + , testProperty "indentGuard combinator" prop_indentGuard + , testProperty "charLiteral" prop_charLiteral + , testProperty "integer" prop_integer + , testProperty "decimal" prop_decimal + , testProperty "hexadecimal" prop_hexadecimal + , testProperty "octal" prop_octal + , testProperty "float 0" prop_float_0 + , testProperty "float 1" prop_float_1 + , testProperty "number 0" prop_number_0 + , testProperty "number 1" prop_number_1 + , testProperty "number 2 (signed)" prop_number_2 + , testProperty "signed" prop_signed ] newtype WhiteSpace = WhiteSpace { getWhiteSpace :: String } @@ -211,26 +205,32 @@ , exCh 'e', exSpec "digit" ] s = maybe "" (show . getNonNegative) n' -prop_number :: Either (NonNegative Integer) (NonNegative Double) - -> Integer -> Property -prop_number n' i = checkParser number r s - where r | null s = posErr 0 s [uneEof, exSpec "number"] - | otherwise = - Right $ case n' of +prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property +prop_number_0 n' = checkParser number r s + where r = Right $ case n' of Left x -> Left $ getNonNegative x Right x -> Right $ getNonNegative x - s = if i < 5 - then "" - else either (show . getNonNegative) (show . getNonNegative) n' + s = either (show . getNonNegative) (show . getNonNegative) n' +prop_number_1 :: Property +prop_number_1 = checkParser number r s + where r = posErr 0 s [uneEof, exSpec "number"] + s = "" + +prop_number_2 :: Either Integer Double -> Property +prop_number_2 n = checkParser p (Right n) s + where p = signed (hidden C.space) number + s = either show show n + prop_signed :: Integer -> Int -> Bool -> Property prop_signed n i plus = checkParser p r s where p = signed (hidden C.space) integer r | i > length z = Right n | otherwise = posErr i s $ uneCh '?' : (if i <= 0 then [exCh '+', exCh '-'] else []) ++ - [exSpec $ bool "rest of integer" "integer" $ - isNothing . find isDigit $ take i s] + [exSpec $ if isNothing . find isDigit $ take i s + then "integer" + else "rest of integer"] ++ [exEof | i > head (findIndices isDigit s)] z = let bar = showSigned showInt 0 n "" in if n < 0 || plus then bar else '+' : bar diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -15,17 +15,17 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Main (main) where diff --git a/tests/Perm.hs b/tests/Perm.hs --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -15,24 +15,21 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Perm (tests) where import Control.Applicative -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif import Data.List (nub, elemIndices) import Test.Framework @@ -43,16 +40,11 @@ import Text.Megaparsec.Perm import Util -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t -#endif tests :: Test tests = testGroup "Permutation phrases parsers" [ testProperty "permutation parser pure" prop_pure - , testProperty "permutation test 0" prop_perm_0 ] + , testProperty "permutation test 0" prop_perm_0 ] data CharRows = CharRows { getChars :: (Char, Char, Char) @@ -89,13 +81,13 @@ | length cis > 1 = posErr (cis !! 1) s $ [uneCh c] ++ [exCh a | a `notElem` prec] ++ - [bool (exCh b) exEof (b `elem` prec)] + [if b `elem` prec then exEof else exCh b] | b `notElem` s = posErr (length s) s $ [uneEof, exCh b] ++ [exCh a | a `notElem` s || last s == a] ++ [exCh c | c `notElem` s] - | otherwise = Right ( bool a' (filter (== a) s) (a `elem` s) + | otherwise = Right ( if a `elem` s then filter (== a) s else a' , b - , bool c' c (c `elem` s) ) + , if c `elem` s then c else c' ) bis = elemIndices b s preb = take (bis !! 1) s cis = elemIndices c s diff --git a/tests/Pos.hs b/tests/Pos.hs --- a/tests/Pos.hs +++ b/tests/Pos.hs @@ -15,22 +15,23 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. {-# OPTIONS -fno-warn-orphans #-} module Pos (tests) where +import Control.Exception (try, evaluate) import Data.Char (isAlphaNum) import Data.List (intercalate, isInfixOf, elemIndices) @@ -46,20 +47,21 @@ tests :: Test tests = testGroup "Textual source positions" - [ testProperty "components" prop_components + [ testProperty "components" prop_components + , testProperty "exception on invalid position" prop_exception , testProperty "show file name in source positions" prop_showFileName - , testProperty "show line in source positions" prop_showLine - , testProperty "show column in source positions" prop_showColumn - , testProperty "initial position" prop_initialPos - , testProperty "increment source line" prop_incSourceLine - , testProperty "increment source column" prop_incSourceColumn - , testProperty "set source name" prop_setSourceName - , testProperty "set source line" prop_setSourceLine - , testProperty "set source column" prop_setSourceColumn - , testProperty "position updating" prop_updating ] + , testProperty "show line in source positions" prop_showLine + , testProperty "show column in source positions" prop_showColumn + , testProperty "initial position" prop_initialPos + , testProperty "increment source line" prop_incSourceLine + , testProperty "increment source column" prop_incSourceColumn + , testProperty "set source name" prop_setSourceName + , testProperty "set source line" prop_setSourceLine + , testProperty "set source column" prop_setSourceColumn + , testProperty "position updating" prop_updating ] instance Arbitrary SourcePos where - arbitrary = newPos <$> fileName <*> choose (1, 1000) <*> choose (0, 100) + arbitrary = newPos <$> fileName <*> choose (1, 1000) <*> choose (1, 100) fileName :: Gen String fileName = do @@ -74,6 +76,13 @@ prop_components pos = pos == copy where copy = newPos (sourceName pos) (sourceLine pos) (sourceColumn pos) +prop_exception :: String -> Int -> Int -> Property +prop_exception file l c = ioProperty $ do + result <- try . evaluate $ newPos file l c + return $ r === result + where r | l < 1 || c < 1 = Left $ InvalidTextualPosition file l c + | otherwise = Right $ newPos file l c + prop_showFileName :: SourcePos -> Bool prop_showFileName pos = sourceName pos `isInfixOf` show pos @@ -91,20 +100,20 @@ where ipos = initialPos n prop_incSourceLine :: SourcePos -> NonNegative Int -> Bool -prop_incSourceLine pos l = - d sourceName id pos incp && - d sourceLine (+ l') pos incp && - d sourceColumn id pos incp - where l' = getNonNegative l - incp = incSourceLine pos l' +prop_incSourceLine pos l' = + d sourceName id pos incp && + d sourceLine (+ l) pos incp && + d sourceColumn id pos incp + where l = getNonNegative l' + incp = incSourceLine pos l prop_incSourceColumn :: SourcePos -> NonNegative Int -> Bool -prop_incSourceColumn pos c = - d sourceName id pos incp && - d sourceLine id pos incp && - d sourceColumn (+ c') pos incp - where c' = getNonNegative c - incp = incSourceColumn pos c' +prop_incSourceColumn pos c' = + d sourceName id pos incp && + d sourceLine id pos incp && + d sourceColumn (+ c) pos incp + where c = getNonNegative c' + incp = incSourceColumn pos c prop_setSourceName :: SourcePos -> String -> Bool prop_setSourceName pos n = @@ -114,20 +123,20 @@ where setp = setSourceName pos n prop_setSourceLine :: SourcePos -> Positive Int -> Bool -prop_setSourceLine pos l = - d sourceName id pos setp && - d sourceLine (const l') pos setp && - d sourceColumn id pos setp - where l' = getPositive l - setp = setSourceLine pos l' +prop_setSourceLine pos l' = + d sourceName id pos setp && + d sourceLine (const l) pos setp && + d sourceColumn id pos setp + where l = getPositive l' + setp = setSourceLine pos l -prop_setSourceColumn :: SourcePos -> NonNegative Int -> Bool -prop_setSourceColumn pos c = - d sourceName id pos setp && - d sourceLine id pos setp && - d sourceColumn (const c') pos setp - where c' = getNonNegative c - setp = setSourceColumn pos c' +prop_setSourceColumn :: SourcePos -> Positive Int -> Bool +prop_setSourceColumn pos c' = + d sourceName id pos setp && + d sourceLine id pos setp && + d sourceColumn (const c) pos setp + where c = getPositive c' + setp = setSourceColumn pos c prop_updating :: Int -> SourcePos -> String -> Bool prop_updating w pos "" = updatePosString w pos "" == pos diff --git a/tests/Prim.hs b/tests/Prim.hs --- a/tests/Prim.hs +++ b/tests/Prim.hs @@ -15,31 +15,31 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. {-# OPTIONS -fno-warn-orphans #-} module Prim (tests) where import Control.Applicative -#if MIN_VERSION_base(4,7,0) -import Data.Bool (bool) -#endif import Data.Char (isLetter, toUpper) import Data.Foldable (asum) import Data.List (isPrefixOf) import Data.Maybe (maybeToList, fromMaybe) +import Control.Monad.Cont +import Control.Monad.Except +import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Trans.Identity import qualified Control.Monad.State.Lazy as L @@ -52,64 +52,73 @@ import Test.QuickCheck hiding (label) import Text.Megaparsec.Char -import Text.Megaparsec.Error (Message (..)) +import Text.Megaparsec.Error (Message (..), ParseError, newErrorMessages) import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String import Pos () +import Error () import Util -#if !MIN_VERSION_base(4,7,0) -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t -#endif tests :: Test tests = testGroup "Primitive parser combinators" - [ testProperty "ParsecT functor" prop_functor - , testProperty "ParsecT applicative (<*>)" prop_applicative_0 - , testProperty "ParsecT applicative (*>)" prop_applicative_1 - , testProperty "ParsecT applicative (<*)" prop_applicative_2 + [ testProperty "ParsecT functor" prop_functor + , testProperty "ParsecT applicative (<*>)" prop_applicative_0 + , testProperty "ParsecT applicative (*>)" prop_applicative_1 + , testProperty "ParsecT applicative (<*)" prop_applicative_2 , testProperty "ParsecT alternative empty and (<|>)" prop_alternative_0 - , testProperty "ParsecT alternative (<|>)" prop_alternative_1 - , testProperty "ParsecT alternative (<|>) pos" prop_alternative_2 - , testProperty "ParsecT alternative (<|>) hints" prop_alternative_3 - , testProperty "ParsecT alternative many" prop_alternative_4 - , testProperty "ParsecT alternative some" prop_alternative_5 - , testProperty "ParsecT alternative optional" prop_alternative_6 - , testProperty "ParsecT monad return" prop_monad_0 - , testProperty "ParsecT monad (>>)" prop_monad_1 - , testProperty "ParsecT monad (>>=)" prop_monad_2 - , testProperty "ParsecT monad fail" prop_monad_3 - , testProperty "combinator unexpected" prop_unexpected - , testProperty "combinator label" prop_label - , testProperty "combinator hidden hints" prop_hidden_0 - , testProperty "combinator hidden error" prop_hidden_1 - , testProperty "combinator try" prop_try - , testProperty "combinator lookAhead" prop_lookAhead_0 - , testProperty "combinator lookAhead hints" prop_lookAhead_1 - , testProperty "combinator lookAhead messages" prop_lookAhead_2 - , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 + , testProperty "ParsecT alternative (<|>)" prop_alternative_1 + , testProperty "ParsecT alternative (<|>) pos" prop_alternative_2 + , testProperty "ParsecT alternative (<|>) hints" prop_alternative_3 + , testProperty "ParsecT alternative many" prop_alternative_4 + , testProperty "ParsecT alternative some" prop_alternative_5 + , testProperty "ParsecT alternative optional" prop_alternative_6 + , testProperty "ParsecT monad return" prop_monad_0 + , testProperty "ParsecT monad (>>)" prop_monad_1 + , testProperty "ParsecT monad (>>=)" prop_monad_2 + , testProperty "ParsecT monad fail" prop_monad_3 + , testProperty "ParsecT monad laws: left identity" prop_monad_left_id + , testProperty "ParsecT monad laws: right identity" prop_monad_right_id + , testProperty "ParsecT monad laws: associativity" prop_monad_assoc + , testProperty "ParsecT monad reader ask" prop_monad_reader_ask + , testProperty "ParsecT monad reader local" prop_monad_reader_local + , testProperty "ParsecT monad state get" prop_monad_state_get + , testProperty "ParsecT monad state put" prop_monad_state_put + , testProperty "ParsecT monad cont" prop_monad_cont + , testProperty "ParsecT monad error: throw" prop_monad_error_throw + , testProperty "ParsecT monad error: catch" prop_monad_error_catch + , testProperty "combinator unexpected" prop_unexpected + , testProperty "combinator failure" prop_failure + , testProperty "combinator label" prop_label + , testProperty "combinator hidden hints" prop_hidden_0 + , testProperty "combinator hidden error" prop_hidden_1 + , testProperty "combinator try" prop_try + , testProperty "combinator lookAhead" prop_lookAhead_0 + , testProperty "combinator lookAhead hints" prop_lookAhead_1 + , testProperty "combinator lookAhead messages" prop_lookAhead_2 + , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1 - , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 - , testProperty "combinator token" prop_token - , testProperty "combinator tokens" prop_tokens - , testProperty "parser state position" prop_state_pos - , testProperty "parser state input" prop_state_input - , testProperty "parser state tab width" prop_state_tab - , testProperty "parser state general" prop_state - , testProperty "IdentityT try" prop_IdentityT_try - , testProperty "IdentityT notFollowedBy" prop_IdentityT_notFollowedBy - , testProperty "ReaderT try" prop_ReaderT_try - , testProperty "ReaderT notFollowedBy" prop_ReaderT_notFollowedBy + , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 + , testProperty "combinator token" prop_token + , testProperty "combinator tokens" prop_tokens + , testProperty "parser state position" prop_state_pos + , testProperty "parser state input" prop_state_input + , testProperty "parser state tab width" prop_state_tab + , testProperty "parser state general" prop_state + , testProperty "custom state parsing" prop_runParser' + , testProperty "custom state parsing (transformer)" prop_runParserT' + , testProperty "IdentityT try" prop_IdentityT_try + , testProperty "IdentityT notFollowedBy" prop_IdentityT_notFollowedBy + , testProperty "ReaderT try" prop_ReaderT_try + , testProperty "ReaderT notFollowedBy" prop_ReaderT_notFollowedBy , testProperty "StateT alternative (<|>)" prop_StateT_alternative - , testProperty "StateT lookAhead" prop_StateT_lookAhead - , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy - , testProperty "WriterT" prop_WriterT ] + , testProperty "StateT lookAhead" prop_StateT_lookAhead + , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy + , testProperty "WriterT" prop_WriterT ] instance Arbitrary (State String) where - arbitrary = State <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = State <$> arbitrary <*> arbitrary <*> choose (1, 20) -- Functor instance @@ -218,33 +227,82 @@ | otherwise = posErr 0 s [msg m] s = "" --- TODO MonadReader instance of ParsecT +prop_monad_left_id :: Integer -> Integer -> Property +prop_monad_left_id a b = (return a >>= f) !=! (f a) + where f x = return $ x + b --- TODO MonadState instance of ParsecT +prop_monad_right_id :: Integer -> Property +prop_monad_right_id a = (m >>= return) !=! m + where m = return a --- TODO MonadCont instance of ParsecT +prop_monad_assoc :: Integer -> Integer -> Integer -> Property +prop_monad_assoc a b c = ((m >>= f) >>= g) !=! (m >>= (\x -> f x >>= g)) + where m = return a + f x = return $ x + b + g x = return $ x + c --- TODO MonadError instance of ParsecT +-- MonadReader instance +prop_monad_reader_ask :: Integer -> Property +prop_monad_reader_ask a = runReader (runParserT ask "" "") a === Right a + +prop_monad_reader_local :: Integer -> Integer -> Property +prop_monad_reader_local a b = runReader (runParserT p "" "") a === Right (a + b) + where p = local (+ b) ask + +-- MonadState instance + +prop_monad_state_get :: Integer -> Property +prop_monad_state_get a = L.evalState (runParserT L.get "" "") a === Right a + +prop_monad_state_put :: Integer -> Integer -> Property +prop_monad_state_put a b = L.execState (runParserT (L.put b) "" "") a === b + +-- MonadCont instance + +prop_monad_cont :: Integer -> Integer -> Property +prop_monad_cont a b = runCont (runParserT p "" "") id === Right (max a b) + where p = do x <- callCC $ \e -> when (a > b) (e a) >> return b + return x + +-- MonadError instance + +prop_monad_error_throw :: Integer -> Integer -> Property +prop_monad_error_throw a b = runExcept (runParserT p "" "") === Left a + where p = throwError a >> return b + +prop_monad_error_catch :: Integer -> Integer -> Property +prop_monad_error_catch a b = + runExcept (runParserT p "" "") === Right (Right $ a + b) + where p = (throwError a >> return b) `catchError` handler + handler e = return $ e + b + -- Primitive combinators prop_unexpected :: String -> Property -prop_unexpected m = conjoin [ checkParser p r s +prop_unexpected m = checkParser p r s + where p = unexpected m :: Parser () + r | null m = posErr 0 s [] + | otherwise = posErr 0 s [uneSpec m] + s = "" + +prop_failure :: [Message] -> Property +prop_failure msgs = conjoin [ checkParser p r s , checkParser (runIdentityT p_IdentityT) r s , checkParser (runReaderT p_ReaderT ()) r s , checkParser (L.evalStateT p_lStateT ()) r s , checkParser (S.evalStateT p_sStateT ()) r s , checkParser (L.runWriterT p_lWriterT) r s , checkParser (S.runWriterT p_sWriterT) r s ] - where p = unexpected m :: Parser () - p_IdentityT = unexpected m :: IdentityT Parser () - p_ReaderT = unexpected m :: ReaderT () Parser () - p_lStateT = unexpected m :: L.StateT () Parser () - p_sStateT = unexpected m :: S.StateT () Parser () - p_lWriterT = unexpected m :: L.WriterT [Integer] Parser () - p_sWriterT = unexpected m :: S.WriterT [Integer] Parser () - r | null m = posErr 0 s [] - | otherwise = posErr 0 s [uneSpec m] + where p = failure msgs :: Parser () + p_IdentityT = failure msgs :: IdentityT Parser () + p_ReaderT = failure msgs :: ReaderT () Parser () + p_lStateT = failure msgs :: L.StateT () Parser () + p_sStateT = failure msgs :: S.StateT () Parser () + p_lWriterT = failure msgs :: L.WriterT [Integer] Parser () + p_sWriterT = failure msgs :: S.WriterT [Integer] Parser () + r | null msgs = posErr 0 s [] + | otherwise = Left $ newErrorMessages msgs (initialPos "") s = "" prop_label :: NonNegative Int -> NonNegative Int @@ -287,8 +345,8 @@ s2 = pre ++ s2' p = try (string s1) <|> string s2 r | s == s1 || s == s2 = Right s - | otherwise = posErr 0 s $ bool [uneStr pre] [uneEof] (null s) - ++ [uneStr pre, exStr s1, exStr s2] + | otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre) + : [uneStr pre, exStr s1, exStr s2] s = pre prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property @@ -400,6 +458,28 @@ updateParserState (f s2) getParserState +-- Running a parser + +prop_runParser' :: State String -> String -> Property +prop_runParser' st s = runParser' p st === r + where p = string s + r = emulateStrParsing st s + +prop_runParserT' :: State String -> String -> Property +prop_runParserT' st s = runIdentity (runParserT' p st) === r + where p = string s + r = emulateStrParsing st s + +emulateStrParsing :: State String + -> String + -> (State String, Either ParseError String) +emulateStrParsing st@(State i pos t) s = + if l == length s + then (State (drop l i) (updatePosString t pos s) t, Right s) + else let uneStuff = if null i then uneEof else uneStr (take (l + 1) i) + in (st, Left $ newErrorMessages (exStr s : [uneStuff]) pos) + where l = length $ takeWhile id $ zipWith (==) s i + -- IdentityT instance of MonadParsec prop_IdentityT_try :: String -> String -> String -> Property @@ -408,8 +488,8 @@ s2 = pre ++ s2' p = try (string s1) <|> string s2 r | s == s1 || s == s2 = Right s - | otherwise = posErr 0 s $ bool [uneStr pre] [uneEof] (null s) - ++ [uneStr pre, exStr s1, exStr s2] + | otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre) + : [uneStr pre, exStr s1, exStr s2] s = pre prop_IdentityT_notFollowedBy :: NonNegative Int -> NonNegative Int @@ -431,8 +511,8 @@ getS2 = asks ((pre ++) . snd) p = try (string =<< getS1) <|> (string =<< getS2) r | s == s1 || s == s2 = Right s - | otherwise = posErr 0 s $ bool [uneStr pre] [uneEof] (null s) - ++ [uneStr pre, exStr s1, exStr s2] + | otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre) + : [uneStr pre, exStr s1, exStr s2] s = pre prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int @@ -447,16 +527,18 @@ -- StateT instance of MonadParsec prop_StateT_alternative :: Integer -> Property -prop_StateT_alternative n = checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" +prop_StateT_alternative n = + checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" where p = L.put n >> ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get p' = S.put n >> ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get prop_StateT_lookAhead :: Integer -> Property -prop_StateT_lookAhead n = checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" +prop_StateT_lookAhead n = + checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" where p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get @@ -476,8 +558,9 @@ -- WriterT instance of MonadParsec prop_WriterT :: String -> String -> Property -prop_WriterT pre post = checkParser (L.runWriterT p) r "abx" .&&. - checkParser (S.runWriterT p') r "abx" +prop_WriterT pre post = + checkParser (L.runWriterT p) r "abx" .&&. + checkParser (S.runWriterT p') r "abx" where logged_letter = letterChar >>= \x -> L.tell [x] >> return x logged_letter' = letterChar >>= \x -> L.tell [x] >> return x logged_eof = eof >> L.tell "EOF" diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -15,17 +15,17 @@ -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- --- This software is provided by the copyright holders "as is" and any --- express or implied warranties, including, but not limited to, the implied --- warranties of merchantability and fitness for a particular purpose are --- disclaimed. In no event shall the copyright holders be liable for any --- direct, indirect, incidental, special, exemplary, or consequential --- damages (including, but not limited to, procurement of substitute goods --- or services; loss of use, data, or profits; or business interruption) --- however caused and on any theory of liability, whether in contract, --- strict liability, or tort (including negligence or otherwise) arising in --- any way out of the use of this software, even if advised of the --- possibility of such damage. +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. module Util ( checkParser @@ -33,6 +33,7 @@ , checkChar , checkString , (/=\) + , (!=!) , abcRow , abcRow' , posErr @@ -118,6 +119,15 @@ (/=\) :: (Eq a, Show a) => Parser a -> a -> Property p /=\ x = simpleParse p "" === Right x + +infix 4 !=! + +-- | @n !=! m@ represents property that holds when results of running @n@ +-- and @m@ parsers are identical. This is useful when checking monad laws +-- for example. + +(!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property +n !=! m = simpleParse n "" === simpleParse m "" -- | @abcRow a b c@ generates string consisting of character “a” repeated -- @a@ times, character “b” repeated @b@ times, and finally character “c”