diff --git a/AUTHORS.md b/AUTHORS.md new file mode 100644 --- /dev/null +++ b/AUTHORS.md @@ -0,0 +1,49 @@ +# Authors + +The following people have contributed to Megaparsec/Parsec library. Due to +the fact that original Parsec project has not been keeping this sort of +file, many contributors are missing from this list, if you've contributed to +Parsec project in the past, please open an issue or a pull request, so we +can add you to this list. + +Names below are sorted alphabetically. + +## Author of original Parsec library + +* Daan Leijen + +## Maintainer + +* Mark Karpov + +## Retired maintainers + +* Antoine Latter +* Derek Elkins + +## Contributors + +* Albert Netymk +* Antoine Latter +* Artyom (@neongreen) +* Auke Booij +* Ben Pence +* Björn Buckwalter +* Bryan O'Sullivan +* Cies Breijs +* Daniel Díaz +* Daniel Gorín +* Dennis Gosnell +* Derek Elkins +* Emil Sköldberg +* Joel Williamson +* Mark Karpov +* Paolo Martini +* redneb +* Reto Kramer +* Rogan Creswick +* Roman Cheplyaka +* Ryan Scott +* Simon Vandel +* Slava Shklyaev +* Tal Walter diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,193 @@ +## Megaparsec 4.0.0 + +### General changes + +* Renamed `many1` → `some` as well as other parsers that had `many1` part in + their names. + +* The following functions are now re-exported from `Control.Applicative`: + `(<|>)`, `many`, `some`, `optional`. See #9. + +* Introduced type class `MonadParsec` in the style of MTL monad + transformers. Eliminated built-in user state since it was not flexible + enough and can be emulated via stack of monads. Now all tools in + Megaparsec work with any instance of `MonadParsec`, not only with + `ParsecT`. + +* Added new function `parseMaybe` for lightweight parsing where error + messages (and thus file name) are not important and entire input should be + parsed. For example it can be used when parsing of single number according + to specification of its format is desired. + +* Fixed bug with `notFollowedBy` always succeeded with parsers that don't + consume input, see #6. + +* Flipped order of arguments in the primitive combinator `label`, see #21. + +* Renamed `tokenPrim` → `token`, removed old `token`, because `tokenPrim` is + more general and original `token` is little used. + +* Made `token` parser more powerful, now its second argument can return + `Either [Message] a` instead of `Maybe a`, so it can influence error + message when parsing of token fails. See #29. + +* Added new primitive combinator `hidden p` which hides “expected” tokens in + error message when parser `p` fails. + +* Tab width is not hard-coded anymore. It can be manipulated via + `getTabWidth` and `setTabWidth`. Default tab-width is `defaultTabWidth`, + which is 8. + +### Error messages + +* Introduced type class `ShowToken` and improved representation of + characters and stings in error messages, see #12. + +* Greatly improved quality of error messages. Fixed entire + `Text.Megaparsec.Error` module, see #14 for more information. Made + possible normal analysis of error messages without “render and re-parse” + approach that previous maintainers had to practice to write even simplest + tests, see module `Utils.hs` in `old-tests` for example. + +* Reduced number of `Message` constructors (now there are only `Unexpected`, + `Expected`, and `Message`). Empty “magic” message strings are ignored now, + all the library now uses explicit error messages. + +* Introduced hint system that greatly improves quality of error messages and + made code of `Text.Megaparsec.Prim` a lot clearer. + +### Built-in combinators + +* All built-in combinators in `Text.Megaparsec.Combinator` now work with any + instance of `Alternative` (some of them even with `Applicaitve`). + +* Added more powerful `count'` parser. This parser can be told to parse from + `m` to `n` occurrences of some thing. `count` is defined in terms of + `count'`. + +* Removed `optionMaybe` parser, because `optional` from + `Control.Applicative` does the same thing. + +* Added combinator `someTill`. + +* These combinators are considered deprecated and will be removed in future: + + * `chainl` + * `chainl1` + * `chainr` + * `chainr1` + * `sepEndBy` + * `sepEndBy1` + +### Character parsing + +* Renamed some parsers: + + * `alphaNum` → `alphaNumChar` + * `digit` → `digitChar` + * `endOfLine` → `eol` + * `hexDigit` → `hexDigitChar` + * `letter` → `letterChar` + * `lower` → `lowerChar` + * `octDigit` → `octDigitChar` + * `space` → `spaceChar` + * `spaces` → `space` + * `upper` → `upperChar` + +* Added new character parsers in `Text.Megaparsec.Char`: + + * `asciiChar` + * `charCategory` + * `controlChar` + * `latin1Char` + * `markChar` + * `numberChar` + * `printChar` + * `punctuationChar` + * `separatorChar` + * `symbolChar` + +* Descriptions of old parsers have been updated to accent some + Unicode-specific moments. For example, old description of `letter` stated + that it parses letters from “a” to “z” and from “A” to “Z”. This is wrong, + since it used `Data.Char.isAlpha` predicate internally and thus parsed + many more characters (letters of non-Latin languages, for example). + +* Added combinators `char'`, `oneOf'`, `noneOf'`, and `string'` which are + case-insensitive variants of `char`, `oneOf`, `noneOf`, and `string` + respectively. + +### Lexer + +* Rewritten parsing of numbers, fixed #2 and #3 (in old Parsec project these + are number 35 and 39 respectively), added per bug tests. + + * Since Haskell report doesn't say anything about sign, `integer` and + `float` now parse numbers without sign. + + * Removed `natural` parser, it's equal to new `integer` now. + + * Renamed `naturalOrFloat` → `number` — this doesn't parse sign too. + + * Added new combinator `signed` to parse all sorts of signed numbers. + +* Transformed `Text.Parsec.Token` into `Text.Megaparsec.Lexer`. Little of + Parsec's code remains in the new lexer module. New module doesn't impose + any assumptions on user and should be vastly more useful and + general. Hairy stuff from original Parsec didn't get here, for example + built-in Haskell functions are used to parse escape sequences and the like + instead of trying to re-implement the whole thing. + +### Other + +* Renamed the following functions: + + * `permute` → `makePermParser` + * `buildExpressionParser` → `makeExprParser` + +* Added comprehensive QuickCheck test suite. + +* Added benchmarks. + +## Parsec 3.1.9 + +* Many and various updates to documentation and package description + (including the homepage links). + +* Add an `Eq` instance for `ParseError`. + +* Fixed a regression from 3.1.6: `runP` is again exported from module + `Text.Parsec`. + +## Parsec 3.1.8 + +* Fix a regression from 3.1.6 related to exports from the main module. + +## Parsec 3.1.7 + +* Fix a regression from 3.1.6 related to the reported position of error + messages. See bug #9 for details. + +* Reset the current error position on success of `lookAhead`. + +## Parsec 3.1.6 + +* Export `Text` instances from `Text.Parsec`. + +* Make `Text.Parsec` exports more visible. + +* Re-arrange `Text.Parsec` exports. + +* Add functions `crlf` and `endOfLine` to `Text.Parsec.Char` for handling + input streams that do not have normalized line terminators. + +* Fix off-by-one error in `Token.charControl`. + +## Parsec 3.1.4 & 3.1.5 + +* Bump dependency on `text`. + +## Parsec 3.1.3 + +* Fix a regression introduced in 3.1.2 related to positions reported by + error messages. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,25 @@ +Copyright © 2015 Megaparsec contributors
+Copyright © 2007 Paolo Martini
+Copyright © 1999–2000 Daan Leijen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +This software is provided by the copyright holders "as is" and any express or +implied warranties, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose are disclaimed. In no +event shall the copyright holders be liable for any direct, indirect, +incidental, special, exemplary, or consequential damages (including, but not +limited to, procurement of substitute goods or services; loss of use, data, +or profits; or business interruption) however caused and on any theory of +liability, whether in contract, strict liability, or tort (including +negligence or otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec.hs @@ -0,0 +1,190 @@ +-- | +-- Module : Text.Megaparsec +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- This module includes everything you need to get started writing a parser. +-- +-- By default this module is set up to parse character data. If you'd like to +-- parse the result of your own tokenizer you should start with the following +-- imports: +-- +-- > import Text.Megaparsec.Prim +-- > import Text.Megaparsec.Combinator +-- +-- Then you can implement your own version of 'satisfy' on top of the +-- 'token' primitive. +-- +-- Typical import section looks like this: +-- +-- > import Text.Megaparsec +-- > import Text.Megaparsec.String +-- > -- import Text.Megaparsec.ByteString +-- > -- import Text.Megaparsec.ByteString.Lazy +-- > -- import Text.Megaparsec.Text +-- > -- import Text.Megaparsec.Text.Lazy +-- +-- As you can see the second import depends on data type you want to use as +-- input stream. It just defines useful type-synonym @Parser@ and +-- @parseFromFile@ function. +-- +-- Megaparsec is capable of a lot. Apart from this standard functionality +-- you can parse permutation phrases with "Text.Megaparsec.Perm" and even +-- entire languages with "Text.Megaparsec.Lexer". These modules should be +-- imported explicitly along with the two modules mentioned above. + +module Text.Megaparsec + ( -- * Running parser + Parsec + , ParsecT + , runParser + , runParserT + , parse + , parseMaybe + , parseTest + -- * Combinators + , (A.<|>) + -- $assocbo + , A.many + -- $many + , A.some + -- $some + , A.optional + -- $optional + , unexpected + , () + , label + , hidden + , try + , lookAhead + , notFollowedBy + , eof + , token + , tokens + , between + , choice + , count + , count' + , endBy + , endBy1 + , manyTill + , someTill + , option + , sepBy + , sepBy1 + , skipMany + , skipSome + -- Deprecated combinators + , chainl + , chainl1 + , chainr + , chainr1 + , sepEndBy + , sepEndBy1 + -- * Character parsing + , newline + , crlf + , eol + , tab + , space + , controlChar + , spaceChar + , upperChar + , lowerChar + , letterChar + , alphaNumChar + , printChar + , digitChar + , octDigitChar + , hexDigitChar + , markChar + , numberChar + , punctuationChar + , symbolChar + , separatorChar + , asciiChar + , latin1Char + , charCategory + , char + , char' + , anyChar + , oneOf + , oneOf' + , noneOf + , noneOf' + , satisfy + , string + , string' + -- * Error messages + , Message (..) + , messageString + , badMessage + , ParseError + , errorPos + , errorMessages + , errorIsUnknown + -- * Textual source position + , SourcePos + , sourceName + , sourceLine + , sourceColumn + -- * Low-level operations + , Stream (..) + , Consumed (..) + , Reply (..) + , State (..) + , getInput + , setInput + , getPosition + , setPosition + , getTabWidth + , setTabWidth + , getParserState + , setParserState + , updateParserState ) +where + +import qualified Control.Applicative as A + +import Text.Megaparsec.Char +import Text.Megaparsec.Combinator +import Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim + +-- $assocbo +-- +-- This combinator implements choice. The parser @p \<|> q@ first applies +-- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails +-- /without consuming any input/, parser @q@ is tried. +-- +-- The parser is called /predictive/ since @q@ is only tried when parser @p@ +-- didn't consume any input (i.e. the look ahead is 1). This +-- non-backtracking behaviour allows for both an efficient implementation of +-- the parser combinators and the generation of good error messages. + +-- $many +-- +-- @many p@ applies the parser @p@ /zero/ or more times. Returns a list of +-- the returned values of @p@. +-- +-- > identifier = (:) <$> letter <*> many (alphaNum <|> char '_') + +-- $some +-- +-- @some p@ applies the parser @p@ /one/ or more times. Returns a list of +-- the returned values of @p@. +-- +-- > word = some letter + +-- $optional +-- +-- @optional p@ tries to apply parser @p@. It will parse @p@ or nothing. It +-- only fails if @p@ fails after consuming input. On success result of @p@ +-- is returned inside of 'Just', on failure 'Nothing' is returned. diff --git a/Text/Megaparsec/ByteString.hs b/Text/Megaparsec/ByteString.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/ByteString.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Text.Megaparsec.ByteString +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Convenience definitions for working with 'C.ByteString'. + +module Text.Megaparsec.ByteString + ( Parser + , parseFromFile ) +where + +import Text.Megaparsec.Error +import Text.Megaparsec.Prim + +import qualified Data.ByteString.Char8 as C + +-- | 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) + +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname = runParser p fname <$> C.readFile fname diff --git a/Text/Megaparsec/ByteString/Lazy.hs b/Text/Megaparsec/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/ByteString/Lazy.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Text.Megaparsec.ByteString.Lazy +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Convenience definitions for working with lazy 'C.ByteString'. + +module Text.Megaparsec.ByteString.Lazy + ( Parser + , parseFromFile ) +where + +import Text.Megaparsec.Error +import Text.Megaparsec.Prim + +import qualified Data.ByteString.Lazy.Char8 as C + +-- | 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) + +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname = runParser p fname <$> C.readFile fname diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Char.hs @@ -0,0 +1,341 @@ +-- | +-- Module : Text.Megaparsec.Char +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Commonly used character parsers. + +module Text.Megaparsec.Char + ( -- * Simple parsers + newline + , crlf + , eol + , tab + , space + -- * Categories of characters + , controlChar + , spaceChar + , upperChar + , lowerChar + , letterChar + , alphaNumChar + , printChar + , digitChar + , octDigitChar + , hexDigitChar + , markChar + , numberChar + , punctuationChar + , symbolChar + , separatorChar + , asciiChar + , latin1Char + , charCategory + , categoryName + -- * More general parsers + , char + , char' + , anyChar + , oneOf + , oneOf' + , noneOf + , noneOf' + , satisfy + -- * Sequence of characters + , string + , string' ) +where + +import Control.Applicative ((<|>)) +import Data.Char +import Data.List (nub) +import Data.Maybe (fromJust) + +import Text.Megaparsec.Combinator +import Text.Megaparsec.Error (Message (..)) +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.ShowToken + +-- | Parses a newline character. + +newline :: MonadParsec s m Char => m Char +newline = char '\n' "newline" + +-- | Parses a carriage return character followed by a newline +-- character. Returns sequence of characters parsed. + +crlf :: MonadParsec s m Char => m String +crlf = string "\r\n" + +-- | Parses a CRLF (see 'crlf') or LF (see 'newline') end of line. +-- Returns the sequence of characters parsed. +-- +-- > eol = (pure <$> newline) <|> crlf + +eol :: MonadParsec s m Char => m String +eol = (pure <$> newline) <|> crlf "end of line" + +-- | Parses a tab character. + +tab :: MonadParsec s m Char => m Char +tab = char '\t' "tab" + +-- | Skips /zero/ or more white space characters. +-- +-- See also: 'skipMany' and 'spaceChar'. + +space :: MonadParsec s m Char => m () +space = skipMany spaceChar + +-- | Parses control characters, which are the non-printing characters of the +-- Latin-1 subset of Unicode. + +controlChar :: MonadParsec s m Char => m Char +controlChar = satisfy isControl "control character" + +-- | Parses a Unicode space character, and the control characters: tab, +-- newline, carriage return, form feed, and vertical tab. + +spaceChar :: MonadParsec s m Char => m Char +spaceChar = satisfy isSpace "white space" + +-- | Parses an upper-case or title-case alphabetic Unicode character. Title +-- case is used by a small number of letter ligatures like the +-- single-character form of Lj. + +upperChar :: MonadParsec s m Char => m Char +upperChar = satisfy isUpper "uppercase letter" + +-- | Parses a lower-case alphabetic Unicode character. + +lowerChar :: MonadParsec s m Char => m Char +lowerChar = satisfy isLower "lowercase letter" + +-- | Parses alphabetic Unicode characters: lower-case, upper-case and +-- title-case letters, plus letters of case-less scripts and modifiers +-- letters. + +letterChar :: MonadParsec s m Char => m Char +letterChar = satisfy isLetter "letter" + +-- | Parses alphabetic or numeric digit Unicode characters. +-- +-- Note that numeric digits outside the ASCII range are parsed by this +-- parser but not by 'digitChar'. Such digits may be part of identifiers but +-- are not used by the printer and reader to represent numbers. + +alphaNumChar :: MonadParsec s m Char => m Char +alphaNumChar = satisfy isAlphaNum "alphanumeric character" + +-- | Parses printable Unicode characters: letters, numbers, marks, +-- punctuation, symbols and spaces. + +printChar :: MonadParsec s m Char => m Char +printChar = satisfy isPrint "printable character" + +-- | Parses an ASCII digit, i.e between “0” and “9”. + +digitChar :: MonadParsec s m Char => m Char +digitChar = satisfy isDigit "digit" + +-- | Parses an octal digit, i.e. between “0” and “7”. + +octDigitChar :: MonadParsec s m Char => m Char +octDigitChar = satisfy isOctDigit "octal digit" + +-- | Parses a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, +-- or “A” and “F”. + +hexDigitChar :: MonadParsec s m Char => m Char +hexDigitChar = satisfy isHexDigit "hexadecimal digit" + +-- | Parses Unicode mark characters, for example accents and the like, which +-- combine with preceding characters. + +markChar :: MonadParsec s m Char => m Char +markChar = satisfy isMark "mark character" + +-- | Parses Unicode numeric characters, including digits from various +-- scripts, Roman numerals, et cetera. + +numberChar :: MonadParsec s m Char => m Char +numberChar = satisfy isNumber "numeric character" + +-- | Parses Unicode punctuation characters, including various kinds of +-- connectors, brackets and quotes. + +punctuationChar :: MonadParsec s m Char => m Char +punctuationChar = satisfy isPunctuation "punctuation" + +-- | Parses Unicode symbol characters, including mathematical and currency +-- symbols. + +symbolChar :: MonadParsec s m Char => m Char +symbolChar = satisfy isSymbol "symbol" + +-- | Parses Unicode space and separator characters. + +separatorChar :: MonadParsec s m Char => m Char +separatorChar = satisfy isSeparator "separator" + +-- | Parses a character from the first 128 characters of the Unicode character set, +-- corresponding to the ASCII character set. + +asciiChar :: MonadParsec s m Char => m Char +asciiChar = satisfy isAscii "ASCII character" + +-- | Parses a character from the first 256 characters of the Unicode +-- character set, corresponding to the ISO 8859-1 (Latin-1) character set. + +latin1Char :: MonadParsec s m Char => m Char +latin1Char = satisfy isLatin1 "Latin-1 character" + +-- | @charCategory cat@ Parses character in Unicode General Category @cat@, +-- see 'Data.Char.GeneralCategory'. + +charCategory :: MonadParsec s m Char => GeneralCategory -> m Char +charCategory cat = satisfy ((== cat) . generalCategory) categoryName cat + +-- | Returns human-readable name of Unicode General Category. + +categoryName :: GeneralCategory -> String +categoryName cat = + fromJust $ lookup cat + [ (UppercaseLetter , "uppercase letter") + , (LowercaseLetter , "lowercase letter") + , (TitlecaseLetter , "titlecase letter") + , (ModifierLetter , "modifier letter") + , (OtherLetter , "other letter") + , (NonSpacingMark , "non-spacing mark") + , (SpacingCombiningMark, "spacing combining mark") + , (EnclosingMark , "enclosing mark") + , (DecimalNumber , "decimal number character") + , (LetterNumber , "letter number character") + , (OtherNumber , "other number character") + , (ConnectorPunctuation, "connector punctuation") + , (DashPunctuation , "dash punctuation") + , (OpenPunctuation , "open punctuation") + , (ClosePunctuation , "close punctuation") + , (InitialQuote , "initial quote") + , (FinalQuote , "final quote") + , (OtherPunctuation , "other punctuation") + , (MathSymbol , "math symbol") + , (CurrencySymbol , "currency symbol") + , (ModifierSymbol , "modifier symbol") + , (OtherSymbol , "other symbol") + , (Space , "white space") + , (LineSeparator , "line separator") + , (ParagraphSeparator , "paragraph separator") + , (Control , "control character") + , (Format , "format character") + , (Surrogate , "surrogate character") + , (PrivateUse , "private-use Unicode character") + , (NotAssigned , "non-assigned Unicode character") ] + +-- | @char c@ parses a single character @c@. +-- +-- > semicolon = char ';' + +char :: MonadParsec s m Char => Char -> m Char +char c = satisfy (== c) showToken c + +-- | The same as 'char' but case-insensitive. This parser returns actually +-- parsed character preserving its case. +-- +-- >>> parseTest (char' 'e') "E" +-- 'E' +-- >>> parseTest (char' 'e') "G" +-- parse error at line 1, column 1: +-- unexpected 'G' +-- expecting 'E' or 'e' + +char' :: MonadParsec s m Char => Char -> m Char +char' = choice . fmap char . extendi . pure + +-- | Extends given list of characters adding uppercase version of every +-- lowercase characters and vice versa. Resulting list is guaranteed to have +-- no duplicates. + +extendi :: String -> String +extendi cs = nub (cs >>= f) + where f c | isLower c = [c, toUpper c] + | isUpper c = [c, toLower c] + | otherwise = [c] + +-- | This parser succeeds for any character. Returns the parsed character. + +anyChar :: MonadParsec s m Char => m Char +anyChar = satisfy (const True) "character" + +-- | @oneOf cs@ succeeds if the current character is in the supplied +-- list of characters @cs@. Returns the parsed character. Note that this +-- parser doesn't automatically generate “expected” component of error +-- message, so usually you should label it manually with 'label' or +-- (''). +-- +-- See also: 'satisfy'. +-- +-- > digit = oneOf ['0'..'9'] "digit" + +oneOf :: MonadParsec s m Char => String -> m Char +oneOf cs = satisfy (`elem` cs) + +-- | The same as 'oneOf', but case-insensitive. Returns the parsed character +-- preserving its case. +-- +-- > vowel = oneOf' "aeiou" "vowel" + +oneOf' :: MonadParsec s m Char => String -> m Char +oneOf' = oneOf . extendi + +-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current +-- character /not/ in the supplied list of characters @cs@. Returns the +-- parsed character. + +noneOf :: MonadParsec s m Char => String -> m Char +noneOf cs = satisfy (`notElem` cs) + +-- | The same as 'noneOf', but case-insensitive. +-- +-- > consonant = noneOf' "aeiou" "consonant" + +noneOf' :: MonadParsec s m Char => String -> m Char +noneOf' = noneOf . extendi + +-- | The parser @satisfy f@ succeeds for any character for which the +-- supplied function @f@ returns 'True'. Returns the character that is +-- actually parsed. +-- +-- > digitChar = satisfy isDigit "digit" +-- > oneOf cs = satisfy (`elem` cs) + +satisfy :: MonadParsec s m Char => (Char -> Bool) -> m Char +satisfy f = token updatePosChar testChar + where testChar x = if f x + then Right x + else Left . pure . Unexpected . showToken $ x + +-- | @string s@ parses a sequence of characters given by @s@. Returns +-- the parsed string (i.e. @s@). +-- +-- > divOrMod = string "div" <|> string "mod" + +string :: MonadParsec s m Char => String -> m String +string = tokens updatePosString (==) + +-- | The same as 'string', but case-insensitive. On success returns string +-- cased as actually parsed input. +-- +-- >>> parseTest (string' "foobar") "foObAr" +-- "foObAr" + +string' :: MonadParsec s m Char => String -> m String +string' = tokens updatePosString test + where test x y = toLower x == toLower y diff --git a/Text/Megaparsec/Combinator.hs b/Text/Megaparsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Combinator.hs @@ -0,0 +1,238 @@ +-- | +-- Module : Text.Megaparsec.Combinator +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Commonly used generic combinators. Note that all combinators works with +-- any 'Alternative' instances. + +module Text.Megaparsec.Combinator + ( between + , choice + , count + , count' + , endBy + , endBy1 + , manyTill + , someTill + , option + , sepBy + , sepBy1 + , skipMany + , skipSome + -- Deprecated combinators + , chainl + , chainl1 + , chainr + , chainr1 + , sepEndBy + , sepEndBy1 ) +where + +import Control.Applicative +import Control.Monad (void) +import Data.Foldable (asum) + +-- | @between open close p@ parses @open@, followed by @p@ and @close@. +-- Returns the value returned by @p@. +-- +-- > braces = between (symbol "{") (symbol "}") + +between :: Applicative m => m open -> m close -> m a -> m a +between open close p = open *> p <* close +{-# INLINE between #-} + +-- | @choice ps@ tries to apply the parsers in the list @ps@ in order, +-- until one of them succeeds. Returns the value of the succeeding parser. + +choice :: (Foldable f, Alternative m) => f (m a) -> m a +choice = asum +{-# INLINE choice #-} + +-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or +-- equal to zero, the parser equals to @return []@. Returns a list of @n@ +-- values. +-- +-- This parser is defined in terms of 'count'', like this: +-- +-- > count n = count' n n + +count :: Alternative m => Int -> m a -> m [a] +count n = count' n n +{-# INLINE count #-} + +-- | @count\' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is +-- not positive or @m > n@, the parser equals to @return []@. Returns a list +-- of parsed values. +-- +-- Please note that @m@ /may/ be negative, in this case effect is the same +-- as if it were equal to zero. + +count' :: Alternative m => Int -> Int -> m a -> m [a] +count' m n p + | n <= 0 || m > n = pure [] + | m > 0 = (:) <$> p <*> count' (pred m) (pred n) p + | otherwise = + let f t ts = maybe [] (:ts) t + in f <$> optional p <*> count' 0 (pred n) p + +-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated +-- and ended by @sep@. Returns a list of values returned by @p@. +-- +-- > cStatements = cStatement `endBy` semicolon + +endBy :: Alternative m => m a -> m sep -> m [a] +endBy p sep = many (p <* sep) +{-# INLINE endBy #-} + +-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated +-- and ended by @sep@. Returns a list of values returned by @p@. + +endBy1 :: Alternative m => m a -> m sep -> m [a] +endBy1 p sep = some (p <* sep) +{-# INLINE endBy1 #-} + +-- | @manyTill p end@ applies parser @p@ /zero/ or more times until +-- parser @end@ succeeds. Returns the list of values returned by @p@. This +-- parser can be used to scan comments: +-- +-- > simpleComment = string "") +-- +-- Note that we need to use 'try' since parsers @anyChar@ and @string +-- \"-->\"@ overlap and @string \"-->\"@ could consume input before failing. + +manyTill :: Alternative m => m a -> m end -> m [a] +manyTill p end = (end *> pure []) <|> someTill p end +{-# INLINE manyTill #-} + +-- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should +-- succeed at least once. + +someTill :: Alternative m => m a -> m end -> m [a] +someTill p end = (:) <$> p <*> manyTill p end +{-# INLINE someTill #-} + +-- | @option x p@ tries to apply parser @p@. If @p@ fails without +-- consuming input, it returns the value @x@, otherwise the value returned +-- by @p@. +-- +-- > priority = option 0 (digitToInt <$> digitChar) + +option :: Alternative m => a -> m a -> m a +option x p = p <|> pure x +{-# INLINE option #-} + +-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of values returned by @p@. +-- +-- > commaSep p = p `sepBy` comma + +sepBy :: Alternative m => m a -> m sep -> m [a] +sepBy p sep = sepBy1 p sep <|> pure [] +{-# INLINE sepBy #-} + +-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of values returned by @p@. + +sepBy1 :: Alternative m => m a -> m sep -> m [a] +sepBy1 p sep = (:) <$> p <*> many (sep *> p) +{-# INLINE sepBy1 #-} + +-- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping +-- its result. +-- +-- > space = skipMany spaceChar + +skipMany :: Alternative m => m a -> m () +skipMany p = void $ many p +{-# INLINE skipMany #-} + +-- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping +-- its result. + +skipSome :: Alternative m => m a -> m () +skipSome p = void $ some p +{-# INLINE skipSome #-} + +-- 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 #-} + +-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, +-- separated and optionally ended by @sep@. Returns a list of values +-- returned by @p@. + +{-# DEPRECATED sepEndBy "Use @sepBy p sep <* optional sep@ instead." #-} + +sepEndBy :: Alternative m => m a -> m sep -> m [a] +sepEndBy p sep = sepBy p sep <* optional sep +{-# INLINE sepEndBy #-} + +-- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, +-- separated and optionally ended by @sep@. Returns a list of values +-- returned by @p@. + +{-# DEPRECATED sepEndBy1 "Use @sepBy1 p sep <* optional sep@ instead." #-} + +sepEndBy1 :: Alternative m => m a -> m sep -> m [a] +sepEndBy1 p sep = sepBy1 p sep <* optional sep +{-# INLINE sepEndBy1 #-} diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Error.hs @@ -0,0 +1,183 @@ +-- | +-- Module : Text.Megaparsec.Error +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Parse errors. + +module Text.Megaparsec.Error + ( Message (..) + , messageString + , badMessage + , ParseError + , errorPos + , errorMessages + , errorIsUnknown + , newErrorMessage + , newErrorUnknown + , addErrorMessage + , setErrorMessage + , setErrorPos + , mergeError + , showMessages ) +where + +import Data.Bool (bool) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) + +import Text.Megaparsec.Pos + +-- | This data type represents parse error messages. There are three kinds +-- of messages: +-- +-- > data Message = Unexpected String +-- > | Expected String +-- > | Message String +-- +-- The fine distinction between different kinds of parse errors allows the +-- system to generate quite good error messages for the user. + +data Message + = Unexpected !String + | Expected !String + | Message !String + deriving (Show, Eq) + +instance Enum Message where + fromEnum (Unexpected _) = 0 + fromEnum (Expected _) = 1 + fromEnum (Message _) = 2 + toEnum _ = error "Text.Megaparsec.Error: toEnum is undefined for Message" + +instance Ord Message where + compare m1 m2 = + case compare (fromEnum m1) (fromEnum m2) of + LT -> LT + EQ -> compare (messageString m1) (messageString m2) + GT -> GT + +-- | Extract the message string from an error message. + +messageString :: Message -> String +messageString (Unexpected s) = s +messageString (Expected s) = s +messageString (Message s) = s + +-- | Test if message string is empty. + +badMessage :: Message -> Bool +badMessage = null . messageString + +-- | The data type @ParseError@ represents parse errors. It provides the +-- source position ('SourcePos') of the error and a list of error messages +-- ('Message'). A @ParseError@ can be returned by the function +-- 'Text.Parsec.Prim.parse'. @ParseError@ is an instance of the 'Show' and +-- 'Eq' type classes. + +data ParseError = ParseError + { -- | Extract the source position from 'ParseError'. + errorPos :: !SourcePos + -- | Extract the list of error messages from 'ParseError'. + , errorMessages :: [Message] } + deriving Eq + +instance Show ParseError where + show e = show (errorPos e) ++ ":\n" ++ showMessages (errorMessages e) + +-- | 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 + +-- | @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) + where pre = filter (< m) ms + post = filter (> m) 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 +-- function does not add the message to the result (it still deletes all +-- messages of the same type, though). + +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 + +-- | @setErrorPos pos err@ returns 'ParseError' identical to @err@, but with +-- position @pos@. + +setErrorPos :: SourcePos -> ParseError -> ParseError +setErrorPos pos (ParseError _ ms) = ParseError pos ms + +-- | Merge two error data structures into one joining their collections of +-- messages and preferring longest match. In other words, earlier error +-- message is discarded. This may seem counter-intuitive, but @mergeError@ +-- is only used to merge error messages of alternative branches of parsing +-- and in this case longest match should be preferred. + +mergeError :: ParseError -> ParseError -> ParseError +mergeError e1@(ParseError pos1 _) e2@(ParseError pos2 ms2) = + case pos1 `compare` pos2 of + LT -> e2 + EQ -> foldr addErrorMessage e1 ms2 + GT -> e1 + +-- | @showMessages ms@ transforms list of error messages @ms@ into +-- their textual representation. + +showMessages :: [Message] -> String +showMessages [] = "unknown parse error" +showMessages ms = tail $ foldMap (fromMaybe "") (zipWith f ns rs) + where (unexpected, ms') = span ((== 0) . fromEnum) ms + (expected, messages) = span ((== 1) . fromEnum) ms' + f prefix m = (prefix ++) <$> m + ns = ["\nunexpected ","\nexpecting ","\n"] + rs = renderMsgs <$> [unexpected, expected, messages] + +-- | Render collection of messages. If the collection is empty, return +-- 'Nothing', else return textual representation of the messages inside +-- 'Just'. + +renderMsgs :: [Message] -> Maybe String +renderMsgs [] = Nothing +renderMsgs ms = Just . orList $ messageString <$> ms + +-- | Print a pretty list where items are separated with commas and the word +-- “or” according to rules of English punctuation. + +orList :: [String] -> String +orList [] = "" +orList [x] = x +orList [x,y] = x ++ " or " ++ y +orList xs = intercalate ", " (init xs) ++ ", or " ++ last xs diff --git a/Text/Megaparsec/Expr.hs b/Text/Megaparsec/Expr.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Expr.hs @@ -0,0 +1,144 @@ +-- | +-- Module : Text.Megaparsec.Expr +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : non-portable +-- +-- A helper module to parse expressions. Builds a parser given a table of +-- operators. + +module Text.Megaparsec.Expr + ( Operator (..) + , makeExprParser ) +where + +import Control.Applicative ((<|>)) + +import Text.Megaparsec.Combinator +import Text.Megaparsec.Prim + +-- | This data type specifies operators that work on values of type @a@. +-- An operator is either binary infix or unary prefix or postfix. A binary +-- operator has also an associated associativity. + +data Operator m a + = InfixN (m (a -> a -> a)) -- ^ non-associative infix + | InfixL (m (a -> a -> a)) -- ^ left-associative infix + | InfixR (m (a -> a -> a)) -- ^ right-associative infix + | Prefix (m (a -> a)) -- ^ prefix + | Postfix (m (a -> a)) -- ^ postfix + +-- | @makeExprParser term table@ builds an expression parser for terms +-- @term@ with operators from @table@, taking the associativity and +-- precedence specified in @table@ into account. +-- +-- @table@ is a list of @[Operator s u 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). +-- +-- 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@). +-- +-- @makeExprParser@ takes care of all the complexity involved in building an +-- expression parser. Here is an example of an expression parser that +-- handles prefix signs, postfix increment and basic arithmetic: +-- +-- > expr = makeExprParser term table "expression" +-- > +-- > term = parens expr <|> integer "term" +-- > +-- > table = [ [ prefix "-" negate +-- > , prefix "+" id ] +-- > , [ postfix "++" (+1) ] +-- > , [ binary "*" (*) +-- > , binary "/" div ] +-- > , [ binary "+" (+) +-- > , binary "-" (-) ] ] +-- > +-- > binary name f = InfixL (reservedOp name >> return f) +-- > prefix name f = Prefix (reservedOp name >> return f) +-- > postfix name f = Postfix (reservedOp name >> return f) +-- +-- Please note that multi-character operators should use 'try' in order to +-- be reported correctly in error messages. + +makeExprParser :: MonadParsec s m t => m a -> [[Operator m a]] -> m a +makeExprParser = foldl addPrecLevel + +-- | @addPrecLevel p ops@ adds ability to parse operators in table @ops@ to +-- parser @p@. + +addPrecLevel :: MonadParsec s m t => m a -> [Operator m a] -> m a +addPrecLevel term ops = + term' >>= \x -> choice [ras' x, las' x, nas' x, return x] "operator" + where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops + term' = pTerm (choice prefix) term (choice postfix) + ras' = pInfixR (choice ras) term' + las' = pInfixL (choice las) term' + nas' = pInfixN (choice nas) term' + +-- | @pTerm prefix term postfix@ parses term with @term@ surrounded by +-- optional prefix and postfix unary operators. Parsers @prefix@ and +-- @postfix@ are allowed to fail, in this case 'id' is used. + +pTerm :: MonadParsec s m t => m (a -> a) -> m a -> m (a -> a) -> m a +pTerm prefix term postfix = do + pre <- option id (hidden prefix) + x <- term + post <- option id (hidden postfix) + return $ post (pre x) + +-- | @pInfixN op p x@ parses non-associative infix operator @op@, then term +-- with parser @p@, then returns result of the operator application on @x@ +-- and the term. + +pInfixN :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a +pInfixN op p x = do + f <- op + y <- p + return $ f x y + +-- | @pInfixL op p x@ parses left-associative infix operator @op@, then term +-- with parser @p@, then returns result of the operator application on @x@ +-- and the term. + +pInfixL :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a +pInfixL op p x = do + f <- op + y <- p + let r = f x y + pInfixL op p r <|> return r + +-- | @pInfixR op p x@ parses right-associative infix operator @op@, then +-- term with parser @p@, then returns result of the operator application on +-- @x@ and the term. + +pInfixR :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a +pInfixR op p x = do + f <- op + y <- p >>= \r -> pInfixR op p r <|> return r + return $ f x y + +type Batch m a = + ( [m (a -> a -> a)] + , [m (a -> a -> a)] + , [m (a -> a -> a)] + , [m (a -> a)] + , [m (a -> a)] ) + +-- | A helper to separate various operators (binary, unary, and according to +-- associativity) and return them in a tuple. + +splitOp :: MonadParsec s m t => Operator m a -> Batch m a -> Batch m a +splitOp (InfixR op) (r, l, n, pre, post) = (op:r, l, n, pre, post) +splitOp (InfixL op) (r, l, n, pre, post) = (r, op:l, n, pre, post) +splitOp (InfixN op) (r, l, n, pre, post) = (r, l, op:n, pre, post) +splitOp (Prefix op) (r, l, n, pre, post) = (r, l, n, op:pre, post) +splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post) diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Lexer.hs @@ -0,0 +1,281 @@ +-- | +-- Module : Text.Megaparsec.Lexer +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : non-portable (uses local universal quantification: PolymorphicComponents) +-- +-- High-level parsers to help you write your lexer. The module doesn't +-- impose how you should write your parser, but certain approaches may be +-- more elegant than others. Especially important theme is parsing of write +-- space, comments and indentation. +-- +-- This module is intended to be imported qualified: +-- +-- > import qualified Text.Megaparsec.Lexer as L + +module Text.Megaparsec.Lexer + ( -- * White space and indentation + space + , lexeme + , symbol + , symbol' + , indentGuard + , skipLineComment + , skipBlockComment + -- * Character and string literals + , charLiteral + -- * Numbers + , integer + , decimal + , hexadecimal + , octal + , float + , number + , signed ) +where + +import Control.Applicative ((<|>), some) +import Control.Monad (void) +import Data.Char (readLitChar) +import Data.Maybe (listToMaybe) + +import Text.Megaparsec.Combinator +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.ShowToken +import qualified Text.Megaparsec.Char as C + +-- White space and indentation + +-- | @space spaceChar lineComment blockComment@ produces parser that can +-- parse white space in general. It's expected that you create such a parser +-- once and pass it to other functions in this module as needed (when you +-- see @spaceConsumer@ in documentation, usually it means that something +-- like 'space' is expected there). +-- +-- @spaceChar@ is used to parse trivial space characters. You can use +-- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as +-- your own parser (if you don't want automatically consume newlines, for +-- example). +-- +-- @lineComment@ is used to parse line comments. You can use +-- 'skipLineComment' if you don't need anything special. +-- +-- @blockComment@ is used to parse block (multi-line) comments. You can use +-- 'skipBlockComment' if you don't need anything special. +-- +-- Parsing of white space is an important part of any parser. We propose a +-- convention where every lexeme parser assumes no spaces before the lexeme +-- and consumes all spaces after the lexeme; this is what the 'lexeme' +-- combinator does, and so it's enough to wrap every lexeme parser with +-- 'lexeme' to achieve this. Note that you'll need to call 'space' manually +-- to consume any white space before the first lexeme (i.e. at the beginning +-- of the file). + +space :: MonadParsec s m Char + => m () -- ^ A parser for a space character (e.g. 'C.spaceChar') + -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') + -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') + -> m () +space ch line block = hidden . skipMany $ choice [ch, line, block] + +-- | This is wrapper for lexemes. Typical usage is to supply first argument +-- (parser that consumes white space, probably defined via 'space') and use +-- the resulting function to wrap parsers for every lexeme. +-- +-- > lexeme = L.lexeme spaceConsumer +-- > integer = lexeme L.integer + +lexeme :: MonadParsec s m Char => m () -> m a -> m a +lexeme spc p = p <* spc + +-- | This is a helper to parse symbols, i.e. verbatim strings. You pass the +-- first argument (parser that consumes white space, probably defined via +-- 'space') and then you can use the resulting function to parse strings: +-- +-- > symbol = L.symbol spaceConsumer +-- > +-- > parens = between (symbol "(") (symbol ")") +-- > braces = between (symbol "{") (symbol "}") +-- > angles = between (symbol "<") (symbol ">") +-- > brackets = between (symbol "[") (symbol "]") +-- > semicolon = symbol ";" +-- > comma = symbol "," +-- > colon = symbol ":" +-- > dot = symbol "." + +symbol :: MonadParsec s m Char => m () -> String -> m String +symbol spc = lexeme spc . C.string + +-- | Case-insensitive version of 'symbol'. This may be helpful if you're +-- working with case-insensitive languages. + +symbol' :: MonadParsec s m Char => m () -> String -> m String +symbol' spc = lexeme spc . C.string' + +-- | @indentGuard spaceConsumer test@ first consumes all white space +-- (indentation) with @spaceConsumer@ parser, then it checks column +-- position. It should satisfy supplied predicate @test@, otherwise the +-- parser fails with error message “incorrect indentation”. On success +-- current column position is returned. +-- +-- When you want to parse block of indentation first run this parser with +-- predicate like @(> 1)@ — this will make sure you have some +-- indentation. Use returned value to check indentation on every subsequent +-- line according to syntax of your language. + +indentGuard :: MonadParsec s m Char => m () -> (Int -> Bool) -> m Int +indentGuard spc p = do + spc + pos <- sourceColumn <$> getPosition + if p pos + then return pos + else fail "incorrect indentation" + +-- | Given comment prefix this function returns parser that skips line +-- comments. Note that it stops just before newline character but doesn't +-- consume the newline. Newline is either supposed to be consumed by 'space' +-- parser or picked up manually. + +skipLineComment :: MonadParsec s m Char => String -> m () +skipLineComment prefix = p >> void (manyTill C.anyChar n) + where p = try $ C.string prefix + n = lookAhead C.newline + +-- | @skipBlockComment start end@ skips non-nested block comment starting +-- with @start@ and ending with @end@. + +skipBlockComment :: MonadParsec s m Char => String -> String -> m () +skipBlockComment start end = p >> void (manyTill C.anyChar n) + where p = try $ C.string start + n = try $ C.string end + +-- Character and string literals + +-- | The lexeme parser parses a single literal character without +-- quotes. Purpose of this parser is to help with parsing of commonly used +-- escape sequences. It's your responsibility to take care of character +-- literal syntax in your language (by surrounding it with single quotes or +-- similar). +-- +-- The literal character is parsed according to the grammar rules defined in +-- the Haskell report. +-- +-- Note that you can use this parser as a building block to parse various +-- string literals: +-- +-- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"') + +charLiteral :: MonadParsec s m Char => m Char +charLiteral = label "literal character" $ do + r@(x:_) <- lookAhead $ count' 1 8 C.anyChar + case listToMaybe (readLitChar r) of + Just (c, r') -> count (length r - length r') C.anyChar >> return c + Nothing -> unexpected (showToken x) + +-- Numbers + +-- | Parse an integer without sign in decimal representation (according to +-- format of integer literals described in Haskell report). +-- +-- If you need to parse signed integers, see 'signed' combinator. + +integer :: MonadParsec s m Char => m Integer +integer = decimal "integer" + +-- | The same as 'integer', but 'integer' is 'label'ed with “integer” label, +-- while this parser is labeled with “decimal integer”. + +decimal :: MonadParsec s m Char => m Integer +decimal = nump "" C.digitChar "decimal integer" + +-- | Parse an integer in hexadecimal representation. Representation of +-- hexadecimal number is expected to be according to Haskell report except +-- for the fact that this parser doesn't parse “0x” or “0X” prefix. It is +-- reponsibility of the programmer to parse correct prefix before parsing +-- the number itself. +-- +-- For example you can make it conform to Haskell report like this: +-- +-- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal + +hexadecimal :: MonadParsec s m Char => m Integer +hexadecimal = nump "0x" C.hexDigitChar "hexadecimal integer" + +-- | Parse an integer in octal representation. Representation of octal +-- number is expected to be according to Haskell report except for the fact +-- that this parser doesn't parse “0o” or “0O” prefix. It is responsibility +-- of the programmer to parse correct prefix before parsing the number +-- itself. + +octal :: MonadParsec s m Char => m Integer +octal = nump "0o" C.octDigitChar "octal integer" + +-- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then +-- prepends @prefix@ to returned value and tries to interpret the result as +-- an integer according to Haskell syntax. + +nump :: MonadParsec s m Char => String -> m Char -> m Integer +nump prefix baseDigit = read . (prefix ++) <$> some baseDigit + +-- | Parse a floating point value without sign. Representation of floating +-- point value is expected to be according to Haskell report. +-- +-- If you need to parse signed floats, see 'signed'. + +float :: MonadParsec s m Char => m Double +float = label "float" $ read <$> f + where f = do + d <- some C.digitChar + rest <- fraction <|> fExp + return $ d ++ rest + +-- | This is a helper for 'float' parser. It parses fractional part of +-- floating point number, that is, dot and everything after it. + +fraction :: MonadParsec s m Char => m String +fraction = do + void $ C.char '.' + d <- some C.digitChar + e <- option "" fExp + return $ '.' : d ++ e + +-- | This helper parses exponent of floating point numbers. + +fExp :: MonadParsec s m Char => m String +fExp = do + expChar <- C.char' 'e' + signStr <- option "" (pure <$> choice (C.char <$> "+-")) + d <- some C.digitChar + return $ expChar : signStr ++ d + +-- | Parse a number: either integer or floating point. The parser can handle +-- overlapping grammars graciously. + +number :: MonadParsec s m Char => m (Either Integer Double) +number = (Right <$> try float) <|> (Left <$> integer) "number" + +-- | @signed space p@ parser parses optional sign, then if there is a sign +-- it will consume optional white space (using @space@ parser), then it runs +-- parser @p@ which should return a number. Sign of the number is changed +-- according to previously parsed sign. +-- +-- For example, to parse signed integer you can write: +-- +-- > lexeme = L.lexeme spaceConsumer +-- > integer = lexeme L.integer +-- > signedInteger = signed spaceConsumer integer + +signed :: (MonadParsec s m Char, Num a) => m () -> m a -> m a +signed spc p = ($) <$> option id (lexeme spc sign) <*> p + +-- | Parse a sign and return either 'id' or 'negate' according to parsed +-- sign. + +sign :: (MonadParsec s m Char, Num 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 new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Perm.hs @@ -0,0 +1,123 @@ +-- | +-- Module : Text.Megaparsec.Perm +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : non-portable (uses existentially quantified data constructors) +-- +-- This module implements permutation parsers. The algorithm is described +-- in: /Parsing Permutation Phrases/, by Arthur Baars, Andres Loh and +-- Doaitse Swierstra. Published as a functional pearl at the Haskell +-- Workshop 2001. + +module Text.Megaparsec.Perm + ( PermParser + , makePermParser + , (<$$>) + , (<$?>) + , (<||>) + , (<|?>) ) +where + +import Text.Megaparsec.Combinator (choice) +import Text.Megaparsec.Prim + +infixl 1 <||>, <|?> +infixl 2 <$$>, <$?> + +-- | The type @PermParser s m a@ denotes a permutation parser that, +-- when converted by the 'makePermParser' function, produces instance of +-- 'MonadParsec' @m@ that parses @s@ stream and returns a value of type @a@ +-- on success. +-- +-- Normally, a permutation parser is first build with special operators like +-- ('<||>') and than transformed into a normal parser using +-- 'makePermParser'. + +data PermParser s m a = Perm (Maybe a) [Branch s m a] + +data Branch s m a = forall b. Branch (PermParser s m (b -> a)) (m b) + +-- | The parser @makePermParser perm@ parses a permutation of parser described +-- by @perm@. For example, suppose we want to parse a permutation of: an +-- optional string of @a@'s, the character @b@ and an optional @c@. This can +-- be described by: +-- +-- > test = makePermParser $ +-- > (,,) <$?> ("", some (char 'a')) +-- > <||> char 'b' +-- > <|?> ('_', char 'c') + +makePermParser :: MonadParsec s m t => PermParser s m a -> m a +makePermParser (Perm def xs) = choice (fmap branch xs ++ empty) + where empty = case def of + Nothing -> [] + Just x -> [return x] + branch (Branch perm p) = flip ($) <$> p <*> makePermParser perm + +-- | The expression @f \<$$> p@ creates a fresh permutation parser +-- consisting of parser @p@. The the final result of the permutation parser +-- is the function @f@ applied to the return value of @p@. The parser @p@ is +-- not allowed to accept empty input — use the optional combinator ('<$?>') +-- instead. +-- +-- If the function @f@ takes more than one parameter, the type variable @b@ +-- is instantiated to a functional type which combines nicely with the adds +-- parser @p@ to the ('<||>') combinator. This results in stylized code +-- where a permutation parser starts with a combining function @f@ followed +-- by the parsers. The function @f@ gets its parameters in the order in +-- which the parsers are specified, but actual input can be in any order. + +(<$$>) :: MonadParsec s m t => (a -> b) -> m a -> PermParser s m b +f <$$> p = newperm f <||> p + +-- | The expression @f \<$?> (x, p)@ creates a fresh permutation parser +-- consisting of parser @p@. The the final result of the permutation parser +-- is the function @f@ applied to the return value of @p@. The parser @p@ is +-- optional — if it cannot be applied, the default value @x@ will be used +-- instead. + +(<$?>) :: MonadParsec s m t => (a -> b) -> (a, m a) -> PermParser s m b +f <$?> xp = newperm f <|?> xp + +-- | The expression @perm \<||> p@ adds parser @p@ to the permutation +-- parser @perm@. The parser @p@ is not allowed to accept empty input — use +-- the optional combinator ('<|?>') instead. Returns a new permutation +-- parser that includes @p@. + +(<||>) :: MonadParsec s m t + => PermParser s m (a -> b) -> m a -> PermParser s m b +(<||>) = add + +-- | The expression @perm \<||> (x, p)@ adds parser @p@ to the +-- permutation parser @perm@. The parser @p@ is optional — if it cannot be +-- applied, the default value @x@ will be used instead. Returns a new +-- permutation parser that includes the optional parser @p@. + +(<|?>) :: MonadParsec s m t + => PermParser s m (a -> b) -> (a, m a) -> PermParser s m b +perm <|?> (x, p) = addopt perm x p + +newperm :: MonadParsec s m t + => (a -> b) -> PermParser s m (a -> b) +newperm f = Perm (Just f) [] + +add :: MonadParsec s m t => PermParser s m (a -> b) -> m a -> PermParser s m b +add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs) + where first = Branch perm p + insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p' + +addopt :: MonadParsec s m t + => PermParser s m (a -> b) -> a -> m a -> PermParser s m b +addopt perm@(Perm mf fs) x p = Perm (fmap ($ x) mf) (first : fmap insert fs) + where first = Branch perm p + insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p' + +mapPerms :: MonadParsec s m t + => (a -> b) -> PermParser s m a -> PermParser s m b +mapPerms f (Perm x xs) = Perm (fmap f x) (fmap mapBranch xs) + where mapBranch (Branch perm p) = Branch (mapPerms (f .) perm) p diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Pos.hs @@ -0,0 +1,129 @@ +-- | +-- Module : Text.Megaparsec.Pos +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Textual source position. + +module Text.Megaparsec.Pos + ( SourcePos + , sourceName + , sourceLine + , sourceColumn + , incSourceLine + , incSourceColumn + , setSourceName + , setSourceLine + , setSourceColumn + , newPos + , initialPos + , updatePosChar + , updatePosString + , defaultTabWidth ) +where + +import Data.Data (Data) +import Data.List (foldl') +import Data.Typeable (Typeable) + +-- | The abstract data type @SourcePos@ represents source positions. It +-- contains the name of the source (i.e. file name), a line number and a +-- column number. @SourcePos@ is an instance of the 'Show', 'Eq' and 'Ord' +-- class. + +data SourcePos = SourcePos + { -- | Extract the name of the source from a source position. + sourceName :: String + -- | Extract the line number from a source position. + , sourceLine :: !Int + -- | Extract the column number from a source position. + , sourceColumn :: !Int } + deriving (Eq, Ord, Data, Typeable) + +instance Show SourcePos where + show (SourcePos n l c) + | null n = showLC + | otherwise = "\"" ++ n ++ "\" " ++ showLC + where showLC = "line " ++ show l ++ ", column " ++ show c + +-- | Create a new 'SourcePos' with the given source name, line number and +-- column number. + +newPos :: String -> Int -> Int -> SourcePos +newPos = SourcePos + +-- | Create a new 'SourcePos' with the given source name, and line number +-- and column number set to 1, the upper left. + +initialPos :: String -> SourcePos +initialPos name = newPos name 1 1 + +-- | Increment the line number of a source position. + +incSourceLine :: SourcePos -> Int -> SourcePos +incSourceLine (SourcePos n l c) d = SourcePos n (l + d) c + +-- | Increments the column number of a source position. + +incSourceColumn :: SourcePos -> Int -> SourcePos +incSourceColumn (SourcePos n l c) d = SourcePos n l (c + d) + +-- | Set the name of the source. + +setSourceName :: SourcePos -> String -> SourcePos +setSourceName (SourcePos _ l c) n = SourcePos n l c + +-- | Set the line number of a source position. + +setSourceLine :: SourcePos -> Int -> SourcePos +setSourceLine (SourcePos n _ c) l = SourcePos n l c + +-- | Set the column number of a source position. + +setSourceColumn :: SourcePos -> Int -> SourcePos +setSourceColumn (SourcePos n l _) = SourcePos n l + +-- | Update a source position given a character. The first argument +-- specifies tab width. If the character is a newline (\'\\n\') the line +-- number is incremented by 1. If the character is a tab (\'\\t\') the +-- column number is incremented to the nearest tab position, i.e. @column + +-- width - ((column - 1) \`rem\` width)@. In all other cases, the column is +-- incremented by 1. +-- +-- If given tab width is not positive, 'defaultTabWidth' will be used. + +updatePosChar :: Int -- ^ Tab width + -> SourcePos -- ^ Initial position + -> Char -- ^ Character at the position + -> SourcePos +updatePosChar width (SourcePos n l c) ch = + case ch of + '\n' -> SourcePos n (l + 1) 1 + '\t' -> let w = if width < 1 then defaultTabWidth else width + in SourcePos n l (c + w - ((c - 1) `rem` w)) + _ -> SourcePos n l (c + 1) + +-- | The expression @updatePosString pos s@ updates the source position +-- @pos@ by calling 'updatePosChar' on every character in @s@, i.e. +-- +-- > updatePosString width = foldl (updatePosChar width) + +updatePosString :: Int -- ^ Tab width + -> SourcePos -- ^ Initial position + -> String -- ^ String to process + -> SourcePos +updatePosString w = foldl' (updatePosChar w) + +-- | Value of tab width used by default. This is used as fall-back by +-- 'updatePosChar' and possibly in other cases. Always prefer this constant +-- when you want to refer to default tab width because actual value /may/ +-- change in future. Current value is @8@. + +defaultTabWidth :: Int +defaultTabWidth = 8 diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Prim.hs @@ -0,0 +1,785 @@ +-- | +-- Module : Text.Megaparsec.Prim +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- The primitive parser combinators. + +{-# OPTIONS_HADDOCK not-home #-} + +module Text.Megaparsec.Prim + ( -- * Used data-types + State (..) + , Stream (..) + , Consumed (..) + , Reply (..) + , Parsec + , ParsecT + -- * Primitive combinators + , MonadParsec (..) + , () + -- * Parser state combinators + , getInput + , setInput + , getPosition + , setPosition + , getTabWidth + , setTabWidth + , setParserState + -- * Running parser + , runParser + , runParserT + , parse + , parseMaybe + , parseTest ) +where + +import Data.Bool (bool) +import Data.Monoid + +import Control.Monad +import Control.Monad.Cont.Class +import Control.Monad.Error.Class +import Control.Monad.Identity +import Control.Monad.Reader.Class +import Control.Monad.State.Class hiding (state) +import Control.Monad.Trans +import Control.Monad.Trans.Identity +import qualified Control.Applicative as A +import qualified Control.Monad.Trans.Reader as L +import qualified Control.Monad.Trans.State.Lazy as L +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Lazy as L +import qualified Control.Monad.Trans.Writer.Strict as S + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.ShowToken + +-- | This is Megaparsec state, it's parametrized over stream type @s@. + +data State s = State + { stateInput :: s + , statePos :: !SourcePos + , 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 #-} + +instance Stream TL.Text Char where + uncons = TL.uncons + {-# INLINE uncons #-} + +-- | 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. +-- +-- See also: 'Reply'. + +data Consumed a = Consumed a | Empty !a + +-- | 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. +-- +-- See also: 'Consumed'. + +data Reply s a = Ok a !(State s) | Error ParseError + +-- | 'Hints' represent collection of strings to be included into 'ParserError' +-- as “expected” messages when a parser fails without consuming input right +-- after successful parser that produced the hints. +-- +-- For example, without hints you could get: +-- +-- >>> parseTest (many (char 'r') <* eof) "ra" +-- parse error at line 1, column 2: +-- unexpected 'a' +-- expecting end of input +-- +-- We're getting better error messages with help of hints: +-- +-- >>> parseTest (many (char 'r') <* eof) "ra" +-- parse error at line 1, column 2: +-- unexpected 'a' +-- expecting 'r' or end of input + +newtype Hints = Hints [[String]] deriving Monoid + +-- | Convert 'ParseError' record into 'Hints'. + +toHints :: ParseError -> Hints +toHints err = Hints hints + where hints = if null msgs then [] else [messageString <$> msgs] + msgs = filter ((== 1) . fromEnum) $ errorMessages err + +-- | @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) + +-- | @accHints hs c@ results in “OK” continuation that will add given hints +-- @hs@ to third argument of original continuation @c@. + +accHints :: Hints -> (a -> State s -> Hints -> m b) -> + a -> State s -> Hints -> m b +accHints hs1 c x s hs2 = c x s (hs1 <> hs2) + +-- | Replace most recent group of hints (if any) with given string. Used in +-- 'label' combinator. + +refreshLastHint :: Hints -> String -> Hints +refreshLastHint (Hints []) _ = Hints [] +refreshLastHint (Hints (_:xs)) "" = Hints xs +refreshLastHint (Hints (_:xs)) l = Hints ([l]:xs) + +-- If you're reading this, you may be interested in how Megaparsec works on +-- lower level. That's quite simple. 'ParsecT' is a wrapper around function +-- that takes five arguments: +-- +-- * State. It includes input stream, position in input stream and +-- user's backtracking state. +-- +-- * “Consumed-OK” continuation (cok). This is just a function that +-- takes three arguments: result of parsing, state after parsing, and +-- hints (see their description above). This continuation is called when +-- something has been consumed during parsing and result is OK (no error +-- occurred). +-- +-- * “Consumed-error” continuation (cerr). This function is called when +-- some part of input stream has been consumed and parsing resulted in +-- an error. When error happens, parsing stops and we're only interested +-- in error message, so this continuation takes 'ParseError' as its only +-- argument. +-- +-- * “Empty-OK” continuation (eok). The function takes the same +-- arguments as “consumed-OK” continuation. “Empty-OK” is called when no +-- input has been consumed and no error occurred. +-- +-- * “Empty-error” continuation (eerr). The function is called when no +-- input has been consumed, but nonetheless parsing resulted in an +-- error. Just like “consumed-error”, the continuation take single +-- argument — 'ParseError' record. +-- +-- You call specific continuation when you want to proceed in that specific +-- branch of control flow. + +-- | @Parsec@ is non-transformer variant of more general 'ParsecT' +-- monad transformer. + +type Parsec s = ParsecT s Identity + +-- | @ParsecT s m a@ is a parser with stream type @s@, underlying monad @m@ +-- and return type @a@. + +newtype ParsecT s m a = ParsecT + { unParser :: forall b. State s + -> (a -> State s -> Hints -> m b) -- consumed-OK + -> (ParseError -> m b) -- consumed-error + -> (a -> State s -> Hints -> m b) -- empty-OK + -> (ParseError -> m b) -- empty-error + -> m b } + +instance Functor (ParsecT s m) where + fmap = pMap + +pMap :: (a -> b) -> ParsecT s m a -> ParsecT s m b +pMap f p = ParsecT $ \s cok cerr eok eerr -> + unParser p s (cok . f) cerr (eok . f) eerr +{-# INLINE pMap #-} + +instance A.Applicative (ParsecT s m) where + pure = return + (<*>) = ap + (*>) = (>>) + p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } + +instance A.Alternative (ParsecT s m) where + empty = mzero + (<|>) = mplus + many p = reverse <$> manyAcc p + +manyAcc :: ParsecT s m a -> ParsecT s m [a] +manyAcc p = ParsecT $ \s cok cerr eok _ -> + let errToHints c err = c (toHints err) + walk xs x s' _ = + unParser p s' + (seq xs $ walk $ x:xs) -- consumed-OK + cerr -- consumed-error + manyErr -- empty-OK + (errToHints $ cok (x:xs) s') -- empty-error + in unParser p s (walk []) cerr manyErr (errToHints $ eok [] s) + +manyErr :: a +manyErr = error + "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser \ + \that accepts an empty string." + +instance Monad (ParsecT s m) where + return = pReturn + (>>=) = pBind + fail = pFail + +pReturn :: a -> ParsecT s m a +pReturn x = ParsecT $ \s _ _ eok _ -> eok x s mempty +{-# INLINE pReturn #-} + +pBind :: ParsecT s m a -> (a -> ParsecT s m b) -> ParsecT s m b +pBind m k = ParsecT $ \s cok cerr eok eerr -> + let mcok x s' hs = unParser (k x) s' cok cerr + (accHints hs cok) (withHints hs cerr) + meok x s' hs = unParser (k x) s' cok cerr + (accHints hs eok) (withHints hs eerr) + in unParser m s mcok cerr meok eerr +{-# INLINE pBind #-} + +pFail :: String -> ParsecT s m a +pFail msg = ParsecT $ \s _ _ _ eerr -> + eerr $ newErrorMessage (Message msg) (statePos s) +{-# INLINE pFail #-} + +-- | Low-level creation of the ParsecT type. + +mkPT :: Monad m => (State s -> m (Consumed (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 + +instance MonadIO m => MonadIO (ParsecT s m) where + liftIO = lift . liftIO + +instance MonadReader r m => MonadReader r (ParsecT s m) where + ask = lift ask + local f p = mkPT $ \s -> local f (runParsecT p s) + +instance MonadState s m => MonadState s (ParsecT s' m) where + get = lift get + put = lift . put + +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) + +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 + +instance MonadPlus (ParsecT s m) where + mzero = pZero + mplus = pPlus + +pZero :: ParsecT s m a +pZero = ParsecT $ \(State _ pos _) _ _ _ eerr -> eerr $ newErrorUnknown pos + +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) + neok x s' hs = eok x s' (toHints err <> hs) + neerr err' = eerr (mergeError err' err) + in unParser n s cok ncerr neok neerr + in unParser m s cok cerr eok meerr +{-# INLINE pPlus #-} + +instance MonadTrans (ParsecT s) where + lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty + +-- Primitive combinators + +-- | Type class describing parsers independent of input type. + +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 parsers 'fail', ('') and 'unexpected' are the three parsers used + -- to generate error messages. Of these, only ('') is commonly used. + + unexpected :: String -> m a + + -- | The parser @label name p@ behaves as parser @p@, but whenever the + -- parser @p@ fails /without consuming any input/, it replaces names of + -- “expected” tokens with the name @name@. + + label :: String -> m a -> m a + + -- | @hidden p@ behaves just like parser @p@, but it doesn't show any + -- “expected” tokens in error message when @p@ fails. + + hidden :: m a -> m a + hidden = label "" + + -- | The parser @try p@ behaves like parser @p@, except that it + -- pretends that it hasn't consumed any input when an error occurs. + -- + -- This combinator is used whenever arbitrary look ahead is needed. Since + -- it pretends that it hasn't consumed any input when @p@ fails, the + -- ('A.<|>') combinator will try its second alternative even when the + -- first parser failed while consuming input. + -- + -- For example, here is a parser that will /try/ (sorry for the pun) to + -- parse word “let” or “lexical”: + -- + -- >>> parseTest (string "let" <|> string "lexical") "lexical" + -- parse error at line 1, column 1: + -- unexpected "lex" + -- expecting "let" + -- + -- What happens here? First parser consumes “le” and fails (because it + -- doesn't see a “t”). The second parser, however, isn't tried, since the + -- first parser has already consumed some input! @try@ fixes this + -- behavior and allows backtracking to work: + -- + -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" + -- "lexical" + -- + -- @try@ also improves error messages in case of overlapping alternatives, + -- because Megaparsec's hint system can be used: + -- + -- >>> parseTest (try (string "let") <|> string "lexical") "le" + -- parse error at line 1, column 1: + -- unexpected "le" + -- expecting "let" or "lexical" + + try :: m a -> m a + + -- | @lookAhead p@ parses @p@ without consuming any input. + -- + -- If @p@ fails and consumes some input, so does @lookAhead@. Combine with + -- 'try' if this is undesirable. + + lookAhead :: m a -> m a + + -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser + -- does not consume any input and can be used to implement the “longest + -- match” rule. + + notFollowedBy :: m a -> m () + + -- | This parser only succeeds at the end of the input. + + eof :: m () + + -- | The parser @token nextPos testTok@ accepts a token @t@ with result + -- @x@ when the function @testTok t@ returns @'Right' x@. The position of + -- the /next/ token should be returned when @nextPos@ is called with the + -- tab width, current source position, and the current token. + -- + -- This is the most primitive combinator for accepting tokens. For + -- example, the 'Text.Megaparsec.Char.char' parser could be implemented + -- as: + -- + -- > char c = token updatePosChar testChar + -- > where testChar x = if x == c + -- > then Right x + -- > else Left . pure . Unexpected . showToken $ x + + token :: (Int -> SourcePos -> t -> SourcePos) -- ^ Next position calculating function + -> (t -> Either [Message] a) -- ^ Matching function for the token to parse + -> m a + + -- | The parser @tokens posFromTok test@ parses list of tokens and returns + -- it. @posFromTok@ is called with three arguments: tab width, initial + -- position, and collection of tokens to parse. The resulting parser will + -- use 'showToken' to pretty-print the collection of tokens in error + -- messages. Supplied predicate @test@ is used to check equality of given + -- and parsed tokens. + -- + -- This can be used for example to write 'Text.Megaparsec.Char.string': + -- + -- > string = tokens updatePosString (==) + + tokens :: Eq t + => (Int -> SourcePos -> [t] -> SourcePos) -- ^ Computes position of tokens + -> (t -> t -> Bool) -- ^ Predicate to check equality of tokens + -> [t] -- ^ List of tokens to parse + -> m [t] + + -- | Returns the full parser state as a 'State' record. + + getParserState :: m (State s) + + -- | @updateParserState f@ applies function @f@ to the parser state. + + updateParserState :: (State s -> State s) -> m () + +instance Stream s t => MonadParsec s (ParsecT s m) t where + unexpected = pUnexpected + label = pLabel + try = pTry + lookAhead = pLookAhead + notFollowedBy = pNotFollowedBy + eof = pEof + token = pToken + tokens = pTokens + getParserState = pGetParserState + updateParserState = pUpdateParserState + +pUnexpected :: String -> ParsecT s m a +pUnexpected msg = ParsecT $ \(State _ pos _) _ _ _ eerr -> + eerr $ newErrorMessage (Unexpected msg) pos + +pLabel :: String -> ParsecT s m a -> ParsecT s m a +pLabel l p = ParsecT $ \s cok cerr eok eerr -> + let l' = if null l then l else "rest of " ++ l + cok' x s' hs = cok x s' $ refreshLastHint hs l' + eok' x s' hs = eok x s' $ refreshLastHint hs l + eerr' err = eerr $ setErrorMessage (Expected l) err + in unParser p s cok' cerr eok' eerr' + +pTry :: ParsecT s m a -> ParsecT s m a +pTry p = ParsecT $ \s cok _ eok eerr -> unParser p s cok eerr eok eerr +{-# INLINE pTry #-} + +pLookAhead :: ParsecT s m a -> ParsecT s m a +pLookAhead p = ParsecT $ \s _ cerr eok eerr -> + let eok' a _ _ = eok a s mempty + in unParser p s eok' cerr eok' eerr +{-# INLINE pLookAhead #-} + +pNotFollowedBy :: Stream s t => ParsecT s m a -> ParsecT s m () +pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr -> + let l = maybe eoi (showToken . fst) (uncons input) + cok' _ _ _ = eerr $ unexpectedErr l pos + cerr' _ = eok () s mempty + eok' _ _ _ = eerr $ unexpectedErr l pos + eerr' _ = eok () s mempty + in unParser p s cok' cerr' eok' eerr' + +pEof :: Stream s t => ParsecT s m () +pEof = label eoi $ ParsecT $ \s@(State input pos _) _ _ eok eerr -> + case uncons input of + Nothing -> eok () s mempty + Just (x,_) -> eerr $ unexpectedErr (showToken x) pos +{-# INLINE pEof #-} + +pToken :: Stream s t + => (Int -> SourcePos -> t -> SourcePos) + -> (t -> Either [Message] a) + -> ParsecT s m a +pToken nextpos test = ParsecT $ \(State input pos w) cok _ _ eerr -> + case uncons input of + Nothing -> eerr $ unexpectedErr eoi pos + Just (c,cs) -> + case test c of + Left ms -> eerr $ foldr addErrorMessage (newErrorUnknown pos) ms + Right x -> let newpos = nextpos w pos c + newstate = State cs newpos w + in seq newpos $ seq newstate $ cok x newstate mempty +{-# INLINE pToken #-} + +pTokens :: Stream s t + => (Int -> SourcePos -> [t] -> SourcePos) + -> (t -> t -> Bool) + -> [t] + -> ParsecT s m [t] +pTokens _ _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty +pTokens nextpos test tts = ParsecT $ \(State input pos w) cok cerr _ eerr -> + let errExpect x = setErrorMessage (Expected $ showToken tts) + (newErrorMessage (Unexpected x) pos) + walk [] is rs = let pos' = nextpos w pos tts + s' = State rs pos' w + 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) + in case uncons rs of + Nothing -> errorCont . errExpect $ what + Just (x,xs) + | test t x -> walk ts (x:is) xs + | otherwise -> errorCont . errExpect . showToken $ reverse (x:is) + in walk tts [] input +{-# INLINE pTokens #-} + +pGetParserState :: ParsecT s m (State s) +pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty +{-# INLINE pGetParserState #-} + +pUpdateParserState :: (State s -> State s) -> ParsecT s m () +pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty +{-# INLINE pUpdateParserState #-} + +-- | A synonym for 'label' in form of an operator. + +infix 0 + +() :: MonadParsec s m t => m a -> String -> m a +() = flip label + +unexpectedErr :: String -> SourcePos -> ParseError +unexpectedErr msg = newErrorMessage (Unexpected msg) + +eoi :: String +eoi = "end of input" + +-- Parser state combinators + +-- | Returns the current input. + +getInput :: MonadParsec s m t => m s +getInput = stateInput <$> getParserState + +-- | @setInput input@ continues parsing with @input@. The 'getInput' and +-- @setInput@ functions can for example be used to deal with #include files. + +setInput :: MonadParsec s m t => s -> m () +setInput s = updateParserState (\(State _ pos w) -> State s pos w) + +-- | Returns the current source position. +-- +-- See also: 'SourcePos'. + +getPosition :: MonadParsec s m t => m SourcePos +getPosition = statePos <$> getParserState + +-- | @setPosition pos@ sets the current source position to @pos@. + +setPosition :: MonadParsec s m t => SourcePos -> m () +setPosition pos = updateParserState (\(State s _ w) -> State s pos w) + +-- | Returns tab width. Default tab width is equal to 'defaultTabWidth'. You +-- can set different tab width with help of 'setTabWidth'. + +getTabWidth :: MonadParsec s m t => m Int +getTabWidth = stateTabWidth <$> getParserState + +-- | Set tab width. If argument of the function is not positive number, +-- 'defaultTabWidth' will be used. + +setTabWidth :: MonadParsec s m t => Int -> m () +setTabWidth w = updateParserState (\(State s pos _) -> State s pos w) + +-- | @setParserState st@ set the full parser state to @st@. + +setParserState :: MonadParsec s m t => State s -> m () +setParserState st = updateParserState (const st) + +-- Running a parser + +-- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT' +-- if you're using the 'ParserT' monad transformer; 'parse' itself is just a +-- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a +-- value of type @a@ ('Right'). 'show' or 'print' can be used to turn +-- 'ParseError' into the string representation of the error message. See +-- "Text.Megaparsec.Error" if you need to do more advanced error analysis. +-- +-- > main = case (parse numbers "" "11, 2, 43") of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > +-- > numbers = commaSep integer + +parse :: Stream s t + => Parsec s a -- ^ Parser to run + -> String -- ^ Name of source file, included in error messages + -> s -- ^ Input for parser + -> Either ParseError a +parse = runParser + +-- | @parseMaybe p input@ runs parser @p@ on @input@ and returns result +-- inside 'Just' on success and 'Nothing' on failure. This function also +-- parses 'eof', so if the parser doesn't consume all of its input, it will +-- fail. +-- +-- The function is supposed to be useful for lightweight parsing, where +-- error messages (and thus file name) are not important and entire input +-- should be parsed. For example it can be used when parsing of single +-- number according to specification of its format is desired. + +parseMaybe :: Stream s t => Parsec s a -> s -> Maybe a +parseMaybe p s = + case parse (p <* eof) "" s of + Left _ -> Nothing + Right x -> Just x + +-- | The expression @parseTest p input@ applies a parser @p@ against +-- input @input@ and prints the result to stdout. Used for testing. + +parseTest :: (Stream s t, Show a) => Parsec s a -> s -> IO () +parseTest p input = + case parse p "" input of + Left err -> putStr "parse error at " >> print err + 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 +-- @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 + +-- | 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'). + +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 + +-- | 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))) +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 + +-- 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) + 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 + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +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) + 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 + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +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) + try (L.ReaderT m) = L.ReaderT $ try . m + lookAhead (L.ReaderT m) = L.ReaderT $ \s -> lookAhead (m s) + notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m + unexpected = lift . unexpected + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +instance (MonadPlus m, Monoid w, MonadParsec s m t) + => MonadParsec s (L.WriterT w m) t where + label n (L.WriterT m) = L.WriterT $ label n m + try (L.WriterT m) = L.WriterT $ try m + lookAhead (L.WriterT m) = L.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (L.WriterT m) = L.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + unexpected = lift . unexpected + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +instance (MonadPlus m, Monoid w, MonadParsec s m t) + => MonadParsec s (S.WriterT w m) t where + label n (S.WriterT m) = S.WriterT $ label n m + try (S.WriterT m) = S.WriterT $ try m + lookAhead (S.WriterT m) = S.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (S.WriterT m) = S.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + unexpected = lift . unexpected + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +instance (Monad m, MonadParsec s m t) + => MonadParsec s (IdentityT m) t where + label n (IdentityT m) = IdentityT $ label n m + try = IdentityT . try . runIdentityT + lookAhead (IdentityT m) = IdentityT $ lookAhead m + notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m + unexpected = lift . unexpected + eof = lift eof + token f e = lift $ token f e + tokens f e ts = lift $ tokens f e ts + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f diff --git a/Text/Megaparsec/ShowToken.hs b/Text/Megaparsec/ShowToken.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/ShowToken.hs @@ -0,0 +1,53 @@ +-- | +-- Module : Text.Megaparsec.ShowToken +-- Copyright : © 2015 Megaparsec contributors +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Pretty printing function and instances for use in error messages. + +module Text.Megaparsec.ShowToken (ShowToken (..)) where + +-- | Typeclass 'ShowToken' defines single function 'showToken' that can be +-- used to “pretty-print” various tokens. By default, all commonly used +-- instances are defined, but you can add your own, of course. + +class Show a => ShowToken a where + + -- | Pretty-print given token. This is used to get token representation + -- for use in error messages. + + showToken :: a -> String + +instance ShowToken Char where + showToken = prettyChar + +-- | @prettyChar ch@ returns user-friendly string representation of given +-- character @ch@, suitable for using in error messages, for example. + +prettyChar :: Char -> String +prettyChar '\0' = "null" +prettyChar '\a' = "bell" +prettyChar '\b' = "backspace" +prettyChar '\t' = "tab" +prettyChar '\n' = "newline" +prettyChar '\v' = "vertical tab" +prettyChar '\f' = "form feed" +prettyChar '\r' = "carriage return" +prettyChar ' ' = "space" +prettyChar x = "'" ++ [x] ++ "'" + +instance ShowToken String where + showToken = prettyString + +-- | @prettyString s@ returns pretty representation of string @s@. This is +-- used when printing string tokens in error messages. + +prettyString :: String -> String +prettyString "" = "" +prettyString [x] = prettyChar x +prettyString "\r\n" = "crlf newline" +prettyString xs = "\"" ++ xs ++ "\"" diff --git a/Text/Megaparsec/String.hs b/Text/Megaparsec/String.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/String.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Text.Megaparsec.String +-- Copyright : © 2015 Megaparsec contributors +-- © 2007 Paolo Martini +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Make Strings an instance of 'Stream' with 'Char' token type. + +module Text.Megaparsec.String + ( Parser + , parseFromFile ) +where + +import Text.Megaparsec.Error +import Text.Megaparsec.Prim + +-- | 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 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 <$> readFile fname diff --git a/Text/Megaparsec/Text.hs b/Text/Megaparsec/Text.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Text.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Text.Megaparsec.Text +-- Copyright : © 2015 Megaparsec contributors +-- © 2011 Antoine Latter +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Convenience definitions for working with 'T.Text'. + +module Text.Megaparsec.Text + ( Parser + , parseFromFile ) +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” +-- @Parser@ type and easily change it by importing different “type +-- 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 <$> T.readFile fname diff --git a/Text/Megaparsec/Text/Lazy.hs b/Text/Megaparsec/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Text/Lazy.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Text.Megaparsec.Text.Lazy +-- Copyright : © 2015 Megaparsec contributors +-- © 2011 Antoine Latter +-- License : BSD3 +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Convenience definitions for working with lazy 'T.Text'. + +module Text.Megaparsec.Text.Lazy + ( Parser + , parseFromFile ) +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” +-- @Parser@ type and easily change it by importing different “type +-- 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 <$> T.readFile fname diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,194 @@ +-- -*- Mode: Haskell; -*- +-- +-- Criterion benmarks for Megaparsec, main module. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Criterion.Main + +import Text.Megaparsec + +-- Configuration parameters. + +-- To configure the benchmark, build the benchmarks e.g. like this: +-- $ cabal build --ghc-options="-DBENCHMARK_TYPE=3 -DBENCHMARK_STEPS=10" + +-- BENCHMARK_TYPE options: +-- 0: Text.Megaparsec.String +-- 1: Text.Megaparsec.Text +-- 2: Text.Megaparsec.Text.Lazy +-- 3: Text.Megaparsec.ByteString +-- 4: Text.Megaparsec.ByteString.Lazy + +#ifndef BENCHMARK_TYPE +#define BENCHMARK_TYPE 0 +#endif + +#if BENCHMARK_TYPE == 0 +import Text.Megaparsec.String (Parser) +pack :: String -> String +pack = id +#endif +#if BENCHMARK_TYPE == 1 +import Text.Megaparsec.Text (Parser) +import Data.Text (pack) +#endif +#if BENCHMARK_TYPE == 2 +import Text.Megaparsec.Text.Lazy (Parser) +import Data.Text.Lazy (pack) +#endif +#if BENCHMARK_TYPE == 3 +import Text.Megaparsec.ByteString (Parser) +import Data.ByteString.Char8 (pack) +#endif +#if BENCHMARK_TYPE == 4 +import Text.Megaparsec.ByteString.Lazy (Parser) +import Data.ByteString.Lazy.Char8 (pack) +#endif + +-- benchSteps and benchSize control the benchmark test points +benchSteps :: Int +#if BENCHMARK_STEPS +benchSteps = BENCHMARK_STEPS +#else +benchSteps = 5 +#endif +benchSize :: Int +#if BENCHMARK_SIZE +benchSize = BENCHMARK_SIZE +#else +benchSize = 1000 +#endif + +-- End of configuration parameters + + +main :: IO () +main = defaultMain benchmarks + +benchmarks :: [Benchmark] +benchmarks = + [ + -- First the primitives + bgroup "string" $ benchBunch $ \size str -> + parse (string str :: Parser String) "" + (pack $ replicate size 'a') + , bgroup "try-string" $ benchBunch $ \size str -> + parse (try $ string str :: Parser String) "" + (pack $ replicate size 'a') + , bgroup "lookahead-string" $ benchBunch $ \size str -> + parse (lookAhead $ string str :: Parser String) "" + (pack $ replicate size 'a') + , bgroup "notfollowedby-string" $ benchBunch $ \size str -> + parse (notFollowedBy $ string str :: Parser ()) "" + (pack $ replicate size 'a') + , bgroup "manual-string" benchManual + + -- Now for a few combinators + -- Major class instance operators: return, >>=, <|>, mzero + -- TODO + -- I'm not really sure how to test these operators since I can't imagine what + -- supraconstant complexity they might have. + + -- A few non-primitive combinators follow below + , bgroup "choice" + [ bgroup "match" $ benchBunchMatch $ \size _ -> + parse + (choice (replicate (size-1) (char 'b') ++ [char 'a']) :: Parser Char) + "" + (pack $ replicate size 'a') + , bgroup "nomatch" $ benchBunchMatch $ \size _ -> + parse + (choice (replicate size (char 'b')) :: Parser Char) + "" + (pack $ replicate size 'a') + ] + , bgroup "count'" benchCount + , bgroup "sepBy1" benchSepBy1 + , bgroup "manyTill" $ benchBunchNoMatchLate $ \size _ -> + parse + (manyTill (char 'a') (char 'b') :: Parser String) + "" + (pack $ replicate (size-1) 'a' ++ "b") + ] + + +benchManual :: [Benchmark] +benchManual = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf + (parse (sequence $ fmap char (replicate num 'a') :: Parser String) "") + (pack $ replicate num 'a') + +benchCount :: [Benchmark] +benchCount = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf + (parse (count' size (size*2) (char 'a') :: Parser String) "") + (pack $ replicate (num-1) 'a' ++ "b") + where + size = round ((0.7 :: Double) * fromIntegral num) + +benchSepBy1 :: [Benchmark] +benchSepBy1 = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf + (parse (sepBy1 (char 'a') (char 'b') :: Parser String) "") + (pack $ genString num) + genString 0 = "ac" + genString i = 'a' : 'b' : genString (i-1) + +benchBunch :: (Int -> String -> b) -> [Benchmark] +benchBunch f = + [ bgroup "match" $ benchBunchMatch f + , bgroup "nomatch_early" $ benchBunchNoMatchEarly f + , bgroup "nomatch_late" $ benchBunchNoMatchLate f + ] + +benchBunchMatch :: (Int -> String -> b) -> [Benchmark] +benchBunchMatch f = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf (f num) (replicate num 'a') + +benchBunchNoMatchEarly :: (Int -> String -> b) -> [Benchmark] +benchBunchNoMatchEarly f = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf (f num) (replicate num 'b') + +benchBunchNoMatchLate :: (Int -> String -> b) -> [Benchmark] +benchBunchNoMatchLate f = + map benchOne [benchSize,benchSize*2..benchSize*benchSteps] + where + benchOne num = bench (show num) $ whnf (f num) (replicate (num-1) 'a' ++ "b") diff --git a/megaparsec.cabal b/megaparsec.cabal new file mode 100644 --- /dev/null +++ b/megaparsec.cabal @@ -0,0 +1,177 @@ +-- -*- Mode: Haskell-Cabal; -*- +-- +-- Cabal config for Megaparsec. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +name: megaparsec +version: 4.0.0 +cabal-version: >= 1.10 +license: BSD3 +license-file: LICENSE.md +author: Megaparsec contributors, + Paolo Martini , + Daan Leijen + +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/megaparsec +bug-reports: https://github.com/mrkkrp/megaparsec/issues +category: Parsing +synopsis: Monadic parser combinators +build-type: Simple +description: + + This is industrial-strength monadic parser combinator library. Megaparsec is + a fork of Parsec library originally written by Daan Leijen. + . + Megaparsec is different from Parsec in the following ways: + . + * 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 user. + . + * Megaparsec's code is clearer and doesn't contain “magic” found in original + Parsec. + . + * Megaparsec looks into the future, it does not contain code that serves for + compatibility purposes, it also requires more recent version of `base`. + +extra-source-files: AUTHORS.md, CHANGELOG.md + +library + build-depends: base >= 4.8 && < 5 + , mtl == 2.* + , transformers == 0.4.* + , bytestring + , text >= 0.2 && < 1.3 + default-extensions: + DeriveDataTypeable + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , PolymorphicComponents + , TupleSections + , UndecidableInstances + exposed-modules: Text.Megaparsec + , Text.Megaparsec.ByteString + , Text.Megaparsec.ByteString.Lazy + , Text.Megaparsec.Char + , Text.Megaparsec.Combinator + , Text.Megaparsec.Error + , Text.Megaparsec.Expr + , Text.Megaparsec.Lexer + , Text.Megaparsec.Perm + , Text.Megaparsec.Pos + , Text.Megaparsec.Prim + , Text.Megaparsec.ShowToken + , Text.Megaparsec.String + , Text.Megaparsec.Text + , Text.Megaparsec.Text.Lazy + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite old-tests + main-is: Main.hs + hs-source-dirs: old-tests + type: exitcode-stdio-1.0 + ghc-options: -O2 -Wall + other-modules: Bugs + , Bugs.Bug2 + , Bugs.Bug6 + , Bugs.Bug9 + , Bugs.Bug35 + , Bugs.Bug39 + , Util + build-depends: base >= 4.8 && < 5 + , megaparsec >= 4.0.0 + , HUnit >= 1.2 && < 1.4 + , test-framework >= 0.6 && < 1 + , test-framework-hunit >= 0.2 && < 0.4 + default-extensions: + FlexibleContexts + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + ghc-options: -O2 -Wall -rtsopts + other-modules: Char + , Combinator + , Error + , Expr + , Lexer + , Perm + , Pos + , Prim + , Util + build-depends: base >= 4.8 && < 5 + , megaparsec >= 4.0.0 + , mtl == 2.* + , transformers == 0.4.* + , QuickCheck >= 2.4 && < 3 + , test-framework >= 0.6 && < 1 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + default-extensions: + FlexibleContexts + , FlexibleInstances + default-language: Haskell2010 + +benchmark benchmarks + main-is: Main.hs + hs-source-dirs: benchmarks + type: exitcode-stdio-1.0 + ghc-options: -O2 -Wall -rtsopts + build-depends: base >= 4.8 && < 5 + , megaparsec >= 4.0.0 + , criterion >= 0.6.2.1 && < 1.2 + , text >= 1.2 && < 2 + , bytestring >= 0.10 && < 2 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mrkkrp/megaparsec.git diff --git a/old-tests/Bugs.hs b/old-tests/Bugs.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs.hs @@ -0,0 +1,17 @@ + +module Bugs (bugs) where + +import Test.Framework + +import qualified Bugs.Bug2 +import qualified Bugs.Bug6 +import qualified Bugs.Bug9 +import qualified Bugs.Bug35 +import qualified Bugs.Bug39 + +bugs :: [Test] +bugs = [ Bugs.Bug2.main + , Bugs.Bug6.main + , Bugs.Bug9.main + , Bugs.Bug35.main + , Bugs.Bug39.main ] diff --git a/old-tests/Bugs/Bug2.hs b/old-tests/Bugs/Bug2.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs/Bug2.hs @@ -0,0 +1,33 @@ + +module Bugs.Bug2 (main) where + +import Control.Applicative (empty) +import Control.Monad (void) + +import Text.Megaparsec +import Text.Megaparsec.String +import qualified Text.Megaparsec.Lexer as L + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +sc :: Parser () +sc = L.space (void spaceChar) empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +stringLiteral :: Parser String +stringLiteral = lexeme $ char '"' >> manyTill L.charLiteral (char '"') + +main :: Test +main = + testCase "Control Char Parsing (#2)" $ + parseString "\"test\\^Bstring\"" @?= "test\^Bstring" + where + parseString :: String -> String + parseString input = + case parse stringLiteral "Example" input of + Left{} -> error "Parse failure" + Right str -> str diff --git a/old-tests/Bugs/Bug35.hs b/old-tests/Bugs/Bug35.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs/Bug35.hs @@ -0,0 +1,34 @@ + +module Bugs.Bug35 (main) where + +import Text.Megaparsec +import qualified Text.Megaparsec.Lexer as L + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +trickyFloats :: [String] +trickyFloats = + [ "1.5339794352098402e-118" + , "2.108934760892056e-59" + , "2.250634744599241e-19" + , "5.0e-324" + , "5.960464477539063e-8" + , "0.25996181067141905" + , "0.3572019862807257" + , "0.46817723004874223" + , "0.9640035681058178" + , "4.23808622486133" + , "4.540362294799751" + , "5.212384849884261" + , "13.958257048123212" + , "32.96176575630599" + , "38.47735512322269" ] + +testBatch :: Assertion +testBatch = mapM_ testFloat trickyFloats + where testFloat x = parse L.float "" x @?= Right (read x :: Double) + +main :: Test +main = testCase "Output of Text.Megaparsec.Lexer.float (#35)" testBatch diff --git a/old-tests/Bugs/Bug39.hs b/old-tests/Bugs/Bug39.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs/Bug39.hs @@ -0,0 +1,41 @@ + +module Bugs.Bug39 (main) where + +import Control.Applicative (empty) +import Control.Monad (void) +import Data.Either (isLeft, isRight) + +import Text.Megaparsec +import Text.Megaparsec.String +import qualified Text.Megaparsec.Lexer as L + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +shouldFail :: [String] +shouldFail = [" 1", " +1", " -1"] + +shouldSucceed :: [String] +shouldSucceed = ["1", "+1", "-1", "+ 1 ", "- 1 ", "1 "] + +sc :: Parser () +sc = L.space (void spaceChar) empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +integer :: Parser Integer +integer = lexeme $ L.signed sc L.integer + +testBatch :: Assertion +testBatch = mapM_ (f testFail) shouldFail >> + mapM_ (f testSucceed) shouldSucceed + where f t a = t (parse integer "" a) a + testFail x a = assertBool + ("Should fail on " ++ show a) (isLeft x) + testSucceed x a = assertBool + ("Should succeed on " ++ show a) (isRight x) + +main :: Test +main = testCase "Lexer should fail on leading whitespace (#39)" testBatch diff --git a/old-tests/Bugs/Bug6.hs b/old-tests/Bugs/Bug6.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs/Bug6.hs @@ -0,0 +1,23 @@ + +module Bugs.Bug6 (main) where + +import Text.Megaparsec +import Text.Megaparsec.String + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Util + +main :: Test +main = + testCase "Look-ahead preserving error location (#6)" $ + parseErrors variable "return" @?= ["'return' is a reserved keyword"] + +variable :: Parser String +variable = do + x <- lookAhead (some letterChar) + if x == "return" + then fail "'return' is a reserved keyword" + else string x diff --git a/old-tests/Bugs/Bug9.hs b/old-tests/Bugs/Bug9.hs new file mode 100644 --- /dev/null +++ b/old-tests/Bugs/Bug9.hs @@ -0,0 +1,47 @@ + +module Bugs.Bug9 (main) where + +import Control.Applicative (empty) +import Control.Monad (void) + +import Text.Megaparsec +import Text.Megaparsec.Expr +import Text.Megaparsec.String (Parser) +import qualified Text.Megaparsec.Lexer as L + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Util + +data Expr = Const Integer | Op Expr Expr deriving Show + +main :: Test +main = + testCase "Tracing of current position in error message (#9)" + $ result @?= ["unexpected '>'", "expecting end of input or operator"] + where + result :: [String] + result = parseErrors parseTopLevel "4 >> 5" + +-- Syntax analysis + +sc :: Parser () +sc = L.space (void spaceChar) empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +integer :: Parser Integer +integer = lexeme L.integer + +operator :: String -> Parser String +operator = try . L.symbol sc + +parseTopLevel :: Parser Expr +parseTopLevel = parseExpr <* eof + +parseExpr :: Parser Expr +parseExpr = makeExprParser (Const <$> integer) table + where table = [[ InfixL (Op <$ operator ">>>") ]] diff --git a/old-tests/Main.hs b/old-tests/Main.hs new file mode 100644 --- /dev/null +++ b/old-tests/Main.hs @@ -0,0 +1,7 @@ + +import Test.Framework + +import Bugs (bugs) + +main :: IO () +main = defaultMain [testGroup "Bugs" bugs] diff --git a/old-tests/Util.hs b/old-tests/Util.hs new file mode 100644 --- /dev/null +++ b/old-tests/Util.hs @@ -0,0 +1,13 @@ + +module Util where + +import Text.Megaparsec +import Text.Megaparsec.String (Parser) + +-- | Returns the error messages associated with a failed parse. + +parseErrors :: Parser a -> String -> [String] +parseErrors p input = + case parse p "" input of + Left err -> drop 1 $ lines $ show err + Right _ -> [] diff --git a/tests/Char.hs b/tests/Char.hs new file mode 100644 --- /dev/null +++ b/tests/Char.hs @@ -0,0 +1,253 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's character parsers. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +{-# OPTIONS -fno-warn-orphans #-} + +module Char (tests) where + +import Data.Char +import Data.List (findIndex, isPrefixOf) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Char + +import Util + +tests :: Test +tests = testGroup "Character parsers" + [ testProperty "newline" prop_newline + , testProperty "crlf" prop_crlf + , testProperty "eol" prop_eol + , testProperty "tab" prop_tab + , testProperty "space" prop_space + , testProperty "controlChar" prop_controlChar + , testProperty "spaceChar" prop_spaceChar + , testProperty "upperChar" prop_upperChar + , testProperty "lowerChar" prop_lowerChar + , testProperty "letterChar" prop_letterChar + , testProperty "alphaNumChar" prop_alphaNumChar + , testProperty "printChar" prop_printChar + , testProperty "digitChar" prop_digitChar + , testProperty "hexDigitChar" prop_hexDigitChar + , testProperty "octDigitChar" prop_octDigitChar + , testProperty "markChar" prop_markChar + , testProperty "numberChar" prop_numberChar + , testProperty "punctuationChar" prop_punctuationChar + , testProperty "symbolChar" prop_symbolChar + , testProperty "separatorChar" prop_separatorChar + , testProperty "asciiChar" prop_asciiChar + , testProperty "latin1Char" prop_latin1Char + , testProperty "charCategory" prop_charCategory + , testProperty "char" prop_char + , testProperty "char'" prop_char' + , testProperty "anyChar" prop_anyChar + , testProperty "oneOf" prop_oneOf + , testProperty "oneOf'" prop_oneOf' + , testProperty "noneOf" prop_noneOf + , testProperty "noneOf'" prop_noneOf' + , testProperty "string" prop_string + , testProperty "string'" prop_string' ] + +instance Arbitrary GeneralCategory where + arbitrary = elements + [ UppercaseLetter + , LowercaseLetter + , TitlecaseLetter + , ModifierLetter + , OtherLetter + , NonSpacingMark + , SpacingCombiningMark + , EnclosingMark + , DecimalNumber + , LetterNumber + , OtherNumber + , ConnectorPunctuation + , DashPunctuation + , OpenPunctuation + , ClosePunctuation + , InitialQuote + , FinalQuote + , OtherPunctuation + , MathSymbol + , CurrencySymbol + , ModifierSymbol + , OtherSymbol + , Space + , LineSeparator + , ParagraphSeparator + , Control + , Format + , Surrogate + , PrivateUse + , NotAssigned ] + +prop_newline :: String -> Property +prop_newline = checkChar newline (== '\n') (Just "newline") + +prop_crlf :: String -> Property +prop_crlf = checkString crlf "\r\n" (==) "crlf newline" + +prop_eol :: String -> Property +prop_eol s = checkParser eol r s + where h = head s + r | s == "\n" = Right "\n" + | s == "\r\n" = Right "\r\n" + | null s = posErr 0 s [uneEof, exSpec "end of line"] + | h == '\n' = posErr 1 s [uneCh (s !! 1), exEof] + | h /= '\r' = posErr 0 s [uneCh h, exSpec "end of line"] + | "\r\n" `isPrefixOf` s = posErr 2 s [uneCh (s !! 2), exEof] + | otherwise = posErr 0 s [ uneStr (take 2 s) + , uneCh '\r' + , exSpec "crlf newline" + , exSpec "newline" ] + +prop_tab :: String -> Property +prop_tab = checkChar tab (== '\t') (Just "tab") + +prop_space :: String -> Property +prop_space s = checkParser space r s + where r = case findIndex (not . isSpace) s of + Just x -> + let ch = s !! x + in posErr x s + [ uneCh ch + , uneCh ch + , exSpec "white space" + , exEof ] + Nothing -> Right () + +prop_controlChar :: String -> Property +prop_controlChar = checkChar controlChar isControl (Just "control character") + +prop_spaceChar :: String -> Property +prop_spaceChar = checkChar spaceChar isSpace (Just "white space") + +prop_upperChar :: String -> Property +prop_upperChar = checkChar upperChar isUpper (Just "uppercase letter") + +prop_lowerChar :: String -> Property +prop_lowerChar = checkChar lowerChar isLower (Just "lowercase letter") + +prop_letterChar :: String -> Property +prop_letterChar = checkChar letterChar isAlpha (Just "letter") + +prop_alphaNumChar :: String -> Property +prop_alphaNumChar = + checkChar alphaNumChar isAlphaNum (Just "alphanumeric character") + +prop_printChar :: String -> Property +prop_printChar = checkChar printChar isPrint (Just "printable character") + +prop_digitChar :: String -> Property +prop_digitChar = checkChar digitChar isDigit (Just "digit") + +prop_octDigitChar :: String -> Property +prop_octDigitChar = checkChar octDigitChar isOctDigit (Just "octal digit") + +prop_hexDigitChar :: String -> Property +prop_hexDigitChar = checkChar hexDigitChar isHexDigit (Just "hexadecimal digit") + +prop_markChar :: String -> Property +prop_markChar = checkChar markChar isMark (Just "mark character") + +prop_numberChar :: String -> Property +prop_numberChar = checkChar numberChar isNumber (Just "numeric character") + +prop_punctuationChar :: String -> Property +prop_punctuationChar = + checkChar punctuationChar isPunctuation (Just "punctuation") + +prop_symbolChar :: String -> Property +prop_symbolChar = checkChar symbolChar isSymbol (Just "symbol") + +prop_separatorChar :: String -> Property +prop_separatorChar = checkChar separatorChar isSeparator (Just "separator") + +prop_asciiChar :: String -> Property +prop_asciiChar = checkChar asciiChar isAscii (Just "ASCII character") + +prop_latin1Char :: String -> Property +prop_latin1Char = checkChar latin1Char isLatin1 (Just "Latin-1 character") + +prop_charCategory :: GeneralCategory -> String -> Property +prop_charCategory cat = checkChar (charCategory cat) p (Just $ categoryName cat) + where p c = generalCategory c == cat + +prop_char :: Char -> String -> Property +prop_char c = checkChar (char c) (== c) (Just $ showToken c) + +prop_char' :: Char -> String -> Property +prop_char' c s = checkParser (char' c) r s + where h = head s + l | isLower c = [c, toUpper c] + | isUpper c = [c, toLower c] + | otherwise = [c] + r | null s = posErr 0 s $ uneEof : (exCh <$> l) + | length s == 1 && (h `elemi` l) = Right h + | h `notElemi` l = posErr 0 s $ uneCh h : (exCh <$> l) + | otherwise = posErr 1 s [uneCh (s !! 1), exEof] + +prop_anyChar :: String -> Property +prop_anyChar = checkChar anyChar (const True) (Just "character") + +prop_oneOf :: String -> String -> Property +prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing + +prop_oneOf' :: String -> String -> Property +prop_oneOf' a = checkChar (oneOf' a) (`elemi` a) Nothing + +prop_noneOf :: String -> String -> Property +prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing + +prop_noneOf' :: String -> String -> Property +prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing + +prop_string :: String -> String -> Property +prop_string a = checkString (string a) a (==) (showToken a) + +prop_string' :: String -> String -> Property +prop_string' a = checkString (string' a) a casei (showToken a) + +-- | Case-insensitive equality test for characters. + +casei :: Char -> Char -> Bool +casei x y = toLower x == toLower y + +-- | Case-insensitive 'elem'. + +elemi :: Char -> String -> Bool +elemi c = any (casei c) + +-- | Case-insensitive 'notElem'. + +notElemi :: Char -> String -> Bool +notElemi c = not . elemi c diff --git a/tests/Combinator.hs b/tests/Combinator.hs new file mode 100644 --- /dev/null +++ b/tests/Combinator.hs @@ -0,0 +1,197 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's generic parser combinators. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Combinator (tests) where + +import Control.Applicative +import Data.List (intersperse) +import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Char +import Text.Megaparsec.Combinator + +import Util + +tests :: Test +tests = testGroup "Generic parser combinators" + [ testProperty "combinator between" prop_between + , testProperty "combinator choice" prop_choice + , testProperty "combinator count" prop_count + , testProperty "combinator count'" prop_count' + , testProperty "combinator endBy" prop_endBy + , testProperty "combinator endBy1" prop_endBy1 + , testProperty "combinator manyTill" prop_manyTill + , testProperty "combinator someTill" prop_someTill + , testProperty "combinator option" prop_option + , testProperty "combinator sepBy" prop_sepBy + , testProperty "combinator sepBy1" prop_sepBy1 + , testProperty "combinator skipMany" prop_skipMany + , testProperty "combinator skipSome" prop_skipSome ] + +prop_between :: String -> Char -> NonNegative Int -> String -> Property +prop_between pre c n' post = checkParser p r s + where p = between (string pre) (string post) (many (char c)) + n = getNonNegative n' + b = length $ takeWhile (== c) post + r | b > 0 = posErr (length pre + n + b) s $ exStr post : + if length post == b + then [uneEof] + else [uneCh (post !! b), exCh c] + | otherwise = Right z + z = replicate n c + s = pre ++ z ++ post + +prop_choice :: NonEmptyList Char -> Char -> Property +prop_choice cs' s' = checkParser p r s + where cs = getNonEmpty cs' + p = choice $ char <$> cs + r | s' `elem` cs = Right s' + | otherwise = posErr 0 s $ uneCh s' : (exCh <$> cs) + s = [s'] + +prop_count :: Int -> NonNegative Int -> Property +prop_count n x' = checkParser p r s + where x = getNonNegative x' + p = count n (char 'x') + r = simpleParse (count' n n (char 'x')) s + s = replicate x 'x' + +prop_count' :: Int -> Int -> NonNegative Int -> Property +prop_count' m n x' = checkParser p r s + where x = getNonNegative x' + p = count' m n (char 'x') + r | n <= 0 || m > n = + if x == 0 + then Right "" + else posErr 0 s [uneCh 'x', exEof] + | m <= x && x <= n = Right s + | x < m = posErr x s [uneEof, exCh 'x'] + | otherwise = posErr n s [uneCh 'x', exEof] + s = replicate x 'x' + +prop_endBy :: NonNegative Int -> Char -> Property +prop_endBy n' c = checkParser p r s + where n = getNonNegative n' + p = endBy (char 'a') (char '-') + r | c == 'a' && n == 0 = posErr 1 s [uneEof, exCh '-'] + | c == 'a' = posErr (g n) s [uneCh 'a', exCh '-'] + | c == '-' && n == 0 = posErr 0 s [uneCh '-', exCh 'a', exEof] + | c /= '-' = posErr (g n) s $ uneCh c : + (if n > 0 then exCh '-' else exEof) : + [exCh 'a' | n == 0] + | otherwise = Right (replicate n 'a') + s = intersperse '-' (replicate n 'a') ++ [c] + +prop_endBy1 :: NonNegative Int -> Char -> Property +prop_endBy1 n' c = checkParser p r s + where n = getNonNegative n' + p = endBy1 (char 'a') (char '-') + r | c == 'a' && n == 0 = posErr 1 s [uneEof, exCh '-'] + | c == 'a' = posErr (g n) s [uneCh 'a', exCh '-'] + | c == '-' && n == 0 = posErr 0 s [uneCh '-', exCh 'a'] + | c /= '-' = posErr (g n) s $ uneCh c : + [exCh '-' | n > 0] ++ + -- [exEof | n > 1] ++ + [exCh 'a' | n == 0] + | otherwise = Right (replicate n 'a') + s = intersperse '-' (replicate n 'a') ++ [c] + +prop_manyTill :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_manyTill a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar + r | c == 0 = posErr (a + b) s [uneEof, exCh 'c', exSpec "letter"] + | otherwise = let (pre, post) = break (== 'c') s + in Right (pre, drop 1 post) + s = abcRow a b c + +prop_someTill :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_someTill a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (,) <$> someTill letterChar (char 'c') <*> many letterChar + r | null s = posErr 0 s [uneEof, exSpec "letter"] + | c == 0 = posErr (a + b) s [uneEof, exCh 'c', exSpec "letter"] + | s == "c" = posErr 1 s [uneEof, exCh 'c', exSpec "letter"] + | head s == 'c' = Right ("c", drop 2 s) + | otherwise = let (pre, post) = break (== 'c') s + in Right (pre, drop 1 post) + s = abcRow a b c + +prop_option :: String -> String -> String -> Property +prop_option d a s = checkParser p r s + where p = option d (string a) + r = simpleParse (fromMaybe d <$> optional (string a)) s + +prop_sepBy :: NonNegative Int -> Maybe Char -> Property +prop_sepBy n' c' = checkParser p r s + where n = getNonNegative n' + c = fromJust c' + p = sepBy (char 'a') (char '-') + r | isNothing c' = Right (replicate n 'a') + | c == 'a' && n == 0 = Right "a" + | n == 0 = posErr 0 s [uneCh c, exCh 'a', exEof] + | c == '-' = posErr (length s) s [uneEof, exCh 'a'] + | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof] + s = intersperse '-' (replicate n 'a') ++ maybeToList c' + +prop_sepBy1 :: NonNegative Int -> Maybe Char -> Property +prop_sepBy1 n' c' = checkParser p r s + where n = getNonNegative n' + c = fromJust c' + p = sepBy1 (char 'a') (char '-') + r | isNothing c' && n >= 1 = Right (replicate n 'a') + | isNothing c' = posErr 0 s [uneEof, exCh 'a'] + | c == 'a' && n == 0 = Right "a" + | n == 0 = posErr 0 s [uneCh c, exCh 'a'] + | c == '-' = posErr (length s) s [uneEof, exCh 'a'] + | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof] + s = intersperse '-' (replicate n 'a') ++ maybeToList c' + +prop_skipMany :: Char -> NonNegative Int -> String -> Property +prop_skipMany c n' a = checkParser p r s + where p = skipMany (char c) *> string a + n = getNonNegative n' + r = simpleParse (many (char c) >> string a) s + s = replicate n c ++ a + +prop_skipSome :: Char -> NonNegative Int -> String -> Property +prop_skipSome c n' a = checkParser p r s + where p = skipSome (char c) *> string a + n = getNonNegative n' + r = simpleParse (some (char c) >> string a) s + s = replicate n c ++ a + +g :: Int -> Int +g x = x + if x > 0 then x - 1 else 0 diff --git a/tests/Error.hs b/tests/Error.hs new file mode 100644 --- /dev/null +++ b/tests/Error.hs @@ -0,0 +1,133 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's parse errors. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +{-# OPTIONS -fno-warn-orphans #-} + +module Error (tests) where + +import Data.Bool (bool) +import Data.List (isPrefixOf, isInfixOf) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Pos () +import Text.Megaparsec.Error +import Text.Megaparsec.Pos + +tests :: Test +tests = testGroup "Parse errors" + [ testProperty "extracting 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 ] + +instance Arbitrary Message where + arbitrary = ($) <$> elements constructors <*> arbitrary + where constructors = [Unexpected, Expected, Message] + +instance Arbitrary ParseError where + arbitrary = do + ms <- listOf arbitrary + pe <- oneof [ newErrorUnknown <$> arbitrary + , newErrorMessage <$> arbitrary <*> arbitrary ] + return $ foldr addErrorMessage pe ms + +prop_messageString :: Message -> Bool +prop_messageString m@(Unexpected s) = s == messageString m +prop_messageString m@(Expected s) = s == messageString m +prop_messageString m@(Message s) = s == messageString m + +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) + +prop_wellFormedMessages :: ParseError -> Bool +prop_wellFormedMessages err = wellFormed $ errorMessages err + +prop_parseErrorCopy :: ParseError -> Bool +prop_parseErrorCopy err = + foldr addErrorMessage (newErrorUnknown pos) msgs == err + where pos = errorPos err + msgs = errorMessages err + +prop_setErrorPos :: SourcePos -> ParseError -> Bool +prop_setErrorPos pos err = + errorPos new == pos && errorMessages new == errorMessages err + where new = setErrorPos pos err + +prop_addErrorMessage :: Message -> ParseError -> Bool +prop_addErrorMessage msg err = + wellFormed msgs && (badMessage msg || added) + where new = addErrorMessage msg err + msgs = errorMessages new + added = msg `elem` msgs && not (errorIsUnknown new) + +prop_setErrorMessage :: Message -> ParseError -> Bool +prop_setErrorMessage msg err = + wellFormed msgs && (badMessage msg || (added && unique)) + where new = setErrorMessage msg err + msgs = errorMessages new + added = msg `elem` msgs && not (errorIsUnknown new) + unique = length (filter (== fromEnum msg) (fromEnum <$> msgs)) == 1 + +prop_mergeErrorPos :: ParseError -> ParseError -> Bool +prop_mergeErrorPos e1 e2 = errorPos (mergeError e1 e2) == max pos1 pos2 + where pos1 = errorPos e1 + pos2 = errorPos e2 + +prop_mergeErrorMsgs :: ParseError -> ParseError -> Bool +prop_mergeErrorMsgs e1 e2' = errorPos e1 /= errorPos e2 || wellFormed msgsm + where e2 = setErrorPos (errorPos e1) e2' + msgsm = errorMessages $ mergeError e1 e2 + +prop_visiblePos :: ParseError -> Bool +prop_visiblePos err = show (errorPos err) `isPrefixOf` show err + +prop_visibleMsgs :: ParseError -> Bool +prop_visibleMsgs err = all (`isInfixOf` shown) (errorMessages err >>= f) + where shown = show err + f (Unexpected s) = ["unexpected", s] + f (Expected s) = ["expecting", s] + f (Message s) = [s] + +-- | @iwellFormed xs@ checks that list @xs@ is sorted and contains no +-- duplicates and no empty messages. + +wellFormed :: [Message] -> Bool +wellFormed xs = and (zipWith (<) xs (tail xs)) && not (any badMessage xs) diff --git a/tests/Expr.hs b/tests/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/Expr.hs @@ -0,0 +1,158 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's expression parsers. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Expr (tests) where + +import Control.Applicative (some, (<|>)) +import Data.Bool (bool) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Char +import Text.Megaparsec.Combinator +import Text.Megaparsec.Expr +import Text.Megaparsec.Prim + +import Util + +tests :: Test +tests = testGroup "Expression parsers" + [ testProperty "correctness of expression parser" prop_correctness ] + +-- Algebraic structures to build abstract syntax tree of our expression. + +data Node + = Val Integer -- ^ literal value + | Neg Node -- ^ negation (prefix unary) + | Fac Node -- ^ factorial (postfix unary) + | Mod Node Node -- ^ modulo + | Sum Node Node -- ^ summation (addition) + | Sub Node Node -- ^ subtraction + | Pro Node Node -- ^ product + | Div Node Node -- ^ division + | Exp Node Node -- ^ exponentiation + deriving (Eq, Show) + +instance Enum Node where + fromEnum (Val _) = 0 + fromEnum (Neg _) = 0 + fromEnum (Fac _) = 0 + fromEnum (Mod _ _) = 0 + fromEnum (Exp _ _) = 1 + fromEnum (Pro _ _) = 2 + fromEnum (Div _ _) = 2 + fromEnum (Sum _ _) = 3 + fromEnum (Sub _ _) = 3 + toEnum _ = error "Oops!" + +instance Ord Node where + x `compare` y = fromEnum x `compare` fromEnum y + +showNode :: Node -> String +showNode (Val x) = show x +showNode n@(Neg x) = "-" ++ showGT n x +showNode n@(Fac x) = showGT n x ++ "!" +showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y +showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y +showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y +showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y +showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y +showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y + +showGT :: Node -> Node -> String +showGT parent node = bool showNode showCmp (node > parent) node + +showGE :: Node -> Node -> String +showGE parent node = bool showNode showCmp (node >= parent) node + +showCmp :: Node -> String +showCmp node = bool inParens showNode (fromEnum node == 0) node + +inParens :: Node -> String +inParens x = "(" ++ showNode x ++ ")" + +instance Arbitrary Node where + arbitrary = sized arbitraryN0 + +arbitraryN0 :: Int -> Gen Node +arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf) + , (9, arbitraryN1 n) ] + where leaf = arbitraryN1 (n `div` 2) + +arbitraryN1 :: Int -> Gen Node +arbitraryN1 n = + frequency [ (1, Neg <$> arbitraryN2 n) + , (1, Fac <$> arbitraryN2 n) + , (7, arbitraryN2 n)] + +arbitraryN2 :: Int -> Gen Node +arbitraryN2 0 = Val . getNonNegative <$> arbitrary +arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf + where leaf = arbitraryN0 (n `div` 2) + +-- Some helpers put here since we don't want to depend on +-- "Text.Megaparsec.Lexer". + +lexeme :: MonadParsec s m Char => m a -> m a +lexeme p = p <* hidden space + +symbol :: MonadParsec s m Char => String -> m String +symbol = lexeme . string + +parens :: MonadParsec s m Char => m a -> m a +parens = between (symbol "(") (symbol ")") + +integer :: MonadParsec s m Char => m Integer +integer = lexeme (read <$> some digitChar "integer") + +-- Here we use table of operators that makes use of all features of +-- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex +-- but valid expressions and render them to get their textual +-- representation. + +expr :: MonadParsec s m Char => m Node +expr = makeExprParser term table "expression" + +term :: MonadParsec s m Char => m Node +term = parens expr <|> (Val <$> integer) "term" + +table :: MonadParsec s m Char => [[Operator m Node]] +table = [ [ Prefix (symbol "-" *> pure Neg) + , Postfix (symbol "!" *> pure Fac) + , InfixN (symbol "%" *> pure Mod) ] + , [ InfixR (symbol "^" *> pure Exp) ] + , [ InfixL (symbol "*" *> pure Pro) + , InfixL (symbol "/" *> pure Div) ] + , [ InfixL (symbol "+" *> pure Sum) + , InfixL (symbol "-" *> pure Sub)] ] + +prop_correctness :: Node -> Property +prop_correctness node = checkParser expr (Right node) (showNode node) diff --git a/tests/Lexer.hs b/tests/Lexer.hs new file mode 100644 --- /dev/null +++ b/tests/Lexer.hs @@ -0,0 +1,240 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's lexer. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Lexer (tests) where + +import Control.Applicative (empty) +import Control.Monad (void) +import Data.Bool (bool) +import Data.Char + ( readLitChar + , showLitChar + , isDigit + , isAlphaNum + , isSpace + , toLower ) +import Data.List (findIndices, isInfixOf, find) +import Data.Maybe (listToMaybe, maybeToList, isNothing, fromJust) +import Numeric (showInt, showHex, showOct, showSigned) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Error +import Text.Megaparsec.Lexer +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.String +import qualified Text.Megaparsec.Char as C + +import Util + +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 ] + +newtype WhiteSpace = WhiteSpace + { getWhiteSpace :: String } + deriving (Show, Eq) + +instance Arbitrary WhiteSpace where + arbitrary = WhiteSpace . concat <$> listOf whiteUnit + +newtype Symbol = Symbol + { getSymbol :: String } + deriving (Show, Eq) + +instance Arbitrary Symbol where + arbitrary = Symbol <$> ((++) <$> symbolName <*> whiteChars) + +whiteUnit :: Gen String +whiteUnit = oneof [whiteChars, whiteLine, whiteBlock] + +whiteChars :: Gen String +whiteChars = listOf $ elements "\t\n " + +whiteLine :: Gen String +whiteLine = commentOut <$> arbitrary `suchThat` goodEnough + where commentOut x = "//" ++ x ++ "\n" + goodEnough x = '\n' `notElem` x + +whiteBlock :: Gen String +whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough + where commentOut x = "/*" ++ x ++ "*/" + goodEnough x = not $ "*/" `isInfixOf` x + +symbolName :: Gen String +symbolName = listOf $ arbitrary `suchThat` isAlphaNum + +sc :: Parser () +sc = space (void C.spaceChar) l b + where l = skipLineComment "//" + b = skipBlockComment "/*" "*/" + +sc' :: Parser () +sc' = space (void $ C.oneOf " \t") empty empty + +prop_space :: WhiteSpace -> Property +prop_space w = checkParser p r s + where p = sc + r = Right () + s = getWhiteSpace w + +prop_symbol :: Symbol -> Maybe Char -> Property +prop_symbol = parseSymbol (symbol sc) id + +prop_symbol' :: Symbol -> Maybe Char -> Property +prop_symbol' = parseSymbol (symbol' sc) (fmap toLower) + +parseSymbol :: (String -> Parser String) -> (String -> String) + -> Symbol -> Maybe Char -> Property +parseSymbol p' f s' t = checkParser p r s + where p = p' (f g) + r | g == s || isSpace (last s) = Right g + | otherwise = posErr (length s - 1) s [uneCh (last s), exEof] + g = takeWhile (not . isSpace) s + s = getSymbol s' ++ maybeToList t + +newtype IndLine = IndLine + { getIndLine :: String } + deriving (Show, Eq) + +instance Arbitrary IndLine where + arbitrary = IndLine . concat <$> sequence [spc, sym, spc, eol] + where spc = listOf (elements " \t") + sym = return "xxx" + eol = return "\n" + +prop_indentGuard :: IndLine -> IndLine -> IndLine -> Property +prop_indentGuard l0 l1 l2 = checkParser p r s + where p = ip (> 1) >>= \x -> sp >> ip (== x) >> sp >> ip (> x) >> sp + ip = indentGuard sc' + sp = void $ symbol sc' "xxx" <* C.eol + r | f' l0 <= 1 = posErr 0 s msg' + | f' l1 /= f' l0 = posErr (f l1 + g [l0]) s msg' + | f' l2 <= f' l0 = posErr (f l2 + g [l0, l1]) s msg' + | otherwise = Right () + msg' = [msg "incorrect indentation"] + f = length . takeWhile isSpace . getIndLine + f' x = sourceColumn $ updatePosString defaultTabWidth (initialPos "") $ + take (f x) (getIndLine x) + g xs = sum $ length . getIndLine <$> xs + s = concat $ getIndLine <$> [l0, l1, l2] + +prop_charLiteral :: String -> Bool -> Property +prop_charLiteral t i = checkParser charLiteral r s + where b = listToMaybe $ readLitChar s + (h, g) = fromJust b + r | isNothing b = posErr 0 s $ exSpec "literal character" : + [ if null s then uneEof else uneCh (head s) ] + | null g = Right h + | otherwise = posErr l s [uneCh (head g), exEof] + l = length s - length g + s = if null t || i then t else showLitChar (head t) (tail t) + +prop_integer :: NonNegative Integer -> Int -> Property +prop_integer n' i = checkParser integer r s + where (r, s) = quasiCorrupted n' i showInt "integer" + +prop_decimal :: NonNegative Integer -> Int -> Property +prop_decimal n' i = checkParser decimal r s + where (r, s) = quasiCorrupted n' i showInt "decimal integer" + +prop_hexadecimal :: NonNegative Integer -> Int -> Property +prop_hexadecimal n' i = checkParser hexadecimal r s + where (r, s) = quasiCorrupted n' i showHex "hexadecimal integer" + +prop_octal :: NonNegative Integer -> Int -> Property +prop_octal n' i = checkParser octal r s + where (r, s) = quasiCorrupted n' i showOct "octal integer" + +prop_float_0 :: NonNegative Double -> Property +prop_float_0 n' = checkParser float r s + where n = getNonNegative n' + r = Right n + s = show n + +prop_float_1 :: Maybe (NonNegative Integer) -> Property +prop_float_1 n' = checkParser float r s + where r | isNothing n' = posErr 0 s [uneEof, exSpec "float"] + | otherwise = posErr (length s) s [ uneEof, exCh '.', exCh 'E' + , 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 + Left x -> Left $ getNonNegative x + Right x -> Right $ getNonNegative x + s = if i < 5 + then "" + else either (show . getNonNegative) (show . getNonNegative) 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] + ++ [exEof | i > head (findIndices isDigit s)] + z = let bar = showSigned showInt 0 n "" + in if n < 0 || plus then bar else '+' : bar + s = if i <= length z then take i z ++ "?" ++ drop i z else z + +quasiCorrupted :: NonNegative Integer -> Int + -> (Integer -> String -> String) -> String + -> (Either ParseError Integer, String) +quasiCorrupted n' i shower l = (r, s) + where n = getNonNegative n' + r | i > length z = Right n + | otherwise = posErr i s $ uneCh '?' : + [ exEof | i > 0 ] ++ + [if i <= 0 || null l + then exSpec l + else exSpec $ "rest of " ++ l] + z = shower n "" + s = if i <= length z then take i z ++ "?" ++ drop i z else z diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,52 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec, main module. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Main (main) where + +import Test.Framework (defaultMain) + +import qualified Pos +import qualified Error +import qualified Prim +import qualified Combinator +import qualified Char +import qualified Expr +import qualified Perm +import qualified Lexer + +main :: IO () +main = defaultMain + [ Pos.tests + , Error.tests + , Prim.tests + , Combinator.tests + , Char.tests + , Expr.tests + , Perm.tests + , Lexer.tests ] diff --git a/tests/Perm.hs b/tests/Perm.hs new file mode 100644 --- /dev/null +++ b/tests/Perm.hs @@ -0,0 +1,96 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's permutation phrases parsers. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Perm (tests) where + +import Control.Applicative +import Data.Bool (bool) +import Data.List (nub, elemIndices) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Char +import Text.Megaparsec.Perm + +import Util + +tests :: Test +tests = testGroup "Permutation phrases parsers" + [ testProperty "permutation parser pure" prop_pure + , testProperty "permutation test 0" prop_perm_0 ] + +data CharRows = CharRows + { getChars :: (Char, Char, Char) + , getInput :: String } + deriving (Eq, Show) + +instance Arbitrary CharRows where + arbitrary = do + chars@(a,b,c) <- arbitrary `suchThat` different + an <- arbitrary + bn <- arbitrary + cn <- arbitrary + input <- concat <$> shuffle + [ replicate an a + , replicate bn b + , replicate cn c] + return $ CharRows chars input + where different (a,b,c) = let l = [a,b,c] in l == nub l + +prop_pure :: Integer -> Property +prop_pure n = makePermParser p /=\ n + where p = id <$?> (succ n, pure n) + +prop_perm_0 :: String -> Char -> CharRows -> Property +prop_perm_0 a' c' v = checkParser (makePermParser p) r s + where (a,b,c) = getChars v + p = (,,) <$?> (a', some (char a)) + <||> char b + <|?> (c', char c) + r | length bis > 1 && (length cis <= 1 || head bis < head cis) = + posErr (bis !! 1) s $ [uneCh b, exEof] ++ + [exCh a | a `notElem` preb] ++ + [exCh c | c `notElem` preb] + | length cis > 1 = + posErr (cis !! 1) s $ [uneCh c] ++ + [exCh a | a `notElem` prec] ++ + [bool (exCh b) exEof (b `elem` prec)] + | 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) + , b + , bool c' c (c `elem` s) ) + bis = elemIndices b s + preb = take (bis !! 1) s + cis = elemIndices c s + prec = take (cis !! 1) s + s = getInput v diff --git a/tests/Pos.hs b/tests/Pos.hs new file mode 100644 --- /dev/null +++ b/tests/Pos.hs @@ -0,0 +1,152 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's textual source positions. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +{-# OPTIONS -fno-warn-orphans #-} + +module Pos (tests) where + +import Data.Char (isAlphaNum) +import Data.List (intercalate, isInfixOf, elemIndices) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Text.Megaparsec.Pos + +tests :: Test +tests = testGroup "Textual source positions" + [ testProperty "components" prop_components + , 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 ] + +instance Arbitrary SourcePos where + arbitrary = newPos <$> fileName <*> choose (1, 1000) <*> choose (0, 100) + +fileName :: Gen String +fileName = do + delimiter <- pure <$> elements "/\\" + dirs <- listOf1 simpleName + extension <- simpleName + frequency [ (1, return []) + , (7, return $ intercalate delimiter dirs ++ "." ++ extension)] + where simpleName = listOf1 (arbitrary `suchThat` isAlphaNum) + +prop_components :: SourcePos -> Bool +prop_components pos = pos == copy + where copy = newPos (sourceName pos) (sourceLine pos) (sourceColumn pos) + +prop_showFileName :: SourcePos -> Bool +prop_showFileName pos = + if null name + then '"'`notElem` shown + else ("\"" ++ name ++ "\"") `isInfixOf` shown + where name = sourceName pos + shown = show pos + +prop_showLine :: SourcePos -> Bool +prop_showLine pos = ("line " ++ line) `isInfixOf` show pos + where line = show $ sourceLine pos + +prop_showColumn :: SourcePos -> Bool +prop_showColumn pos = ("column " ++ column) `isInfixOf` show pos + where column = show $ sourceColumn pos + +prop_initialPos :: String -> Bool +prop_initialPos n = + sourceName ipos == n && + sourceLine ipos == 1 && + sourceColumn ipos == 1 + 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_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_setSourceName :: SourcePos -> String -> Bool +prop_setSourceName pos n = + d sourceName (const n) pos setp && + d sourceLine id pos setp && + d sourceColumn id pos setp + 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_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_updating :: Int -> SourcePos -> String -> Bool +prop_updating w pos "" = updatePosString w pos "" == pos +prop_updating w' pos s = + d sourceName id pos updated && + d sourceLine (+ inclines) pos updated && + cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` w == 0)) + where w = if w' < 1 then defaultTabWidth else w' + updated = updatePosString w' pos s + cols = sourceColumn updated + newlines = elemIndices '\n' s + inclines = length newlines + total = length s + mincols = if null newlines + then total + sourceColumn pos + else total - maximum newlines + +d :: Eq b => (a -> b) -> (b -> b) -> a -> a -> Bool +d f g x y = g (f x) == f y diff --git a/tests/Prim.hs b/tests/Prim.hs new file mode 100644 --- /dev/null +++ b/tests/Prim.hs @@ -0,0 +1,492 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec's primitive parser combinators. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +{-# OPTIONS -fno-warn-orphans #-} + +module Prim (tests) where + +import Control.Applicative +import Data.Bool (bool) +import Data.Char (isLetter, toUpper) +import Data.Foldable (asum) +import Data.List (isPrefixOf) +import Data.Maybe (maybeToList, fromMaybe) + +import Control.Monad.Reader +import Control.Monad.Trans.Identity +import qualified Control.Monad.State.Lazy as L +import qualified Control.Monad.State.Strict as S +import qualified Control.Monad.Writer.Lazy as L +import qualified Control.Monad.Writer.Strict as S + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck hiding (label) + +import Text.Megaparsec.Char +import Text.Megaparsec.Error (Message (..)) +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.String + +import Pos () +import Util + +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 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 "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 "StateT alternative (<|>)" prop_StateT_alternative + , 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 + +-- Functor instance + +prop_functor :: Integer -> Integer -> Property +prop_functor n m = + ((+ m) <$> return n) /=\ n + m .&&. ((* n) <$> return m) /=\ n * m + +-- Applicative instance + +prop_applicative_0 :: Integer -> Integer -> Property +prop_applicative_0 n m = ((+) <$> pure n <*> pure m) /=\ n + m + +prop_applicative_1 :: Integer -> Integer -> Property +prop_applicative_1 n m = (pure n *> pure m) /=\ m + +prop_applicative_2 :: Integer -> Integer -> Property +prop_applicative_2 n m = (pure n <* pure m) /=\ n + +-- Alternative instance + +prop_alternative_0 :: Integer -> Property +prop_alternative_0 n = (empty <|> return n) /=\ n + +prop_alternative_1 :: String -> String -> Property +prop_alternative_1 s0 s1 + | s0 == s1 = checkParser p (Right s0) s1 + | null s0 = checkParser p (posErr 0 s1 [uneCh (head s1), exEof]) s1 + | s0 `isPrefixOf` s1 = + checkParser p (posErr s0l s1 [uneCh (s1 !! s0l), exEof]) s1 + | otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1 + where p = try (string s0) <|> string s1 + s0l = length s0 + +prop_alternative_2 :: Char -> Char -> Char -> Bool -> Property +prop_alternative_2 a b c l = checkParser p r s + where p = char a <|> (char b >> char a) + r | l = Right a + | a == b = posErr 1 s [uneCh c, exEof] + | a == c = Right a + | otherwise = posErr 1 s [uneCh c, exCh a] + s = if l then [a] else [b,c] + +prop_alternative_3 :: Property +prop_alternative_3 = checkParser p r s + where p = asum [empty, try (string ">>>"), empty, return "foo"] "bar" + p' = bsum [empty, try (string ">>>"), empty, return "foo"] "bar" + bsum = foldl (<|>) empty + r = simpleParse p' s + s = ">>" + +prop_alternative_4 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_alternative_4 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (++) <$> many (char 'a') <*> many (char 'b') + r | null s = Right s + | c > 0 = posErr (a + b) s $ [uneCh 'c', exCh 'b', exEof] + ++ [exCh 'a' | b == 0] + | otherwise = Right s + s = abcRow a b c + +prop_alternative_5 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_alternative_5 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (++) <$> some (char 'a') <*> some (char 'b') + r | null s = posErr 0 s [uneEof, exCh 'a'] + | a == 0 = posErr 0 s [uneCh (head s), exCh 'a'] + | b == 0 = posErr a s $ [exCh 'a', exCh 'b'] ++ + if c > 0 then [uneCh 'c'] else [uneEof] + | c > 0 = posErr (a + b) s [uneCh 'c', exCh 'b', exEof] + | otherwise = Right s + s = abcRow a b c + +prop_alternative_6 :: Bool -> Bool -> Bool -> Property +prop_alternative_6 a b c = checkParser p r s + where p = f <$> optional (char 'a') <*> optional (char 'b') + f x y = maybe "" (:[]) x ++ maybe "" (:[]) y + r | c = posErr ab s $ [uneCh 'c', exEof] ++ + [exCh 'a' | not a && not b] ++ [exCh 'b' | not b] + | otherwise = Right s + s = abcRow' a b c + ab = fromEnum a + fromEnum b + +-- Monad instance + +prop_monad_0 :: Integer -> Property +prop_monad_0 n = checkParser (return n) (Right n) "" + +prop_monad_1 :: Char -> Char -> Maybe Char -> Property +prop_monad_1 a b c = checkParser p r s + where p = char a >> char b + r = simpleParse (char a *> char b) s + s = a : b : maybeToList c + +prop_monad_2 :: Char -> Char -> Maybe Char -> Property +prop_monad_2 a b c = checkParser p r s + where p = char a >>= \x -> char b >> return x + r = simpleParse (char a <* char b) s + s = a : b : maybeToList c + +prop_monad_3 :: String -> Property +prop_monad_3 m = checkParser p r s + where p = fail m :: Parser () + r | null m = posErr 0 s [] + | otherwise = posErr 0 s [msg m] + s = "" + +-- TODO MonadReader instance of ParsecT + +-- TODO MonadState instance of ParsecT + +-- TODO MonadCont instance of ParsecT + +-- TODO MonadError instance of ParsecT + +-- Primitive combinators + +prop_unexpected :: String -> Property +prop_unexpected m = 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] + s = "" + +prop_label :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> String -> Property +prop_label a' b' c' l = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (++) <$> many (char 'a') <*> (many (char 'b') l) + r | null s = Right s + | c > 0 = posErr (a + b) s $ [uneCh 'c', exEof] + ++ [exCh 'a' | b == 0] + ++ [if b == 0 || null l + then exSpec l + else exSpec $ "rest of " ++ l] + | otherwise = Right s + s = abcRow a b c + +prop_hidden_0 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_hidden_0 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = (++) <$> many (char 'a') <*> hidden (many (char 'b')) + r | null s = Right s + | c > 0 = posErr (a + b) s $ [uneCh 'c', exEof] + ++ [exCh 'a' | b == 0] + | otherwise = Right s + s = abcRow a b c + +prop_hidden_1 :: String -> NonEmptyList Char -> String -> Property +prop_hidden_1 a c' s = checkParser p r s + where c = getNonEmpty c' + p = fromMaybe a <$> optional (hidden $ string c) + r | null s = Right a + | c == s = Right s + | head c /= head s = posErr 0 s [uneCh (head s), exEof] + | otherwise = simpleParse (string c) s + +prop_try :: String -> String -> String -> Property +prop_try pre s1' s2' = checkParser p r s + where s1 = pre ++ s1' + 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] + s = pre + +prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property +prop_lookAhead_0 a b c = checkParser p r s + where p = do + l <- lookAhead (oneOf "ab" "label") + guard (l == h) + char 'a' + h = head s + r | null s = posErr 0 s [uneEof, exSpec "label"] + | s == "a" = Right 'a' + | h == 'b' = posErr 0 s [uneCh 'b', exCh 'a'] + | h == 'c' = posErr 0 s [uneCh 'c', exSpec "label"] + | otherwise = posErr 1 s [uneCh (s !! 1), exEof] + s = abcRow' a b c + +prop_lookAhead_1 :: String -> Property +prop_lookAhead_1 s = checkParser p r s + where p = lookAhead (some letterChar) >> fail "failed" :: Parser () + h = head s + r | null s = posErr 0 s [uneEof, exSpec "letter"] + | isLetter h = posErr 0 s [msg "failed"] + | otherwise = posErr 0 s [uneCh h, exSpec "letter"] + +prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property +prop_lookAhead_2 a b c = checkParser p r s + where p = lookAhead (some (char 'a')) >> char 'b' + r | null s = posErr 0 s [uneEof, exCh 'a'] + | a = posErr 0 s [uneCh 'a', exCh 'b'] + | otherwise = posErr 0 s [uneCh (head s), exCh 'a'] + s = abcRow' a b c + +prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_notFollowedBy_0 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c') + r | b > 0 = posErr a s [uneCh 'b', exCh 'a'] + | otherwise = Right (replicate a 'a') + s = abcRow a b c + +prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_notFollowedBy_1 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'a') <* f (char 'c') <* many (char 'c') + f = notFollowedBy . notFollowedBy -- = 'lookAhead' in this case + r | b == 0 && c > 0 = Right (replicate a 'a') + | b > 0 = posErr a s [uneCh 'b', exCh 'a'] + | otherwise = posErr a s [uneEof, exCh 'a'] + s = abcRow a b c + +prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_notFollowedBy_2 a' b' c' = checkParser p r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'a') <* notFollowedBy eof <* many anyChar + r | b > 0 || c > 0 = Right (replicate a 'a') + | otherwise = posErr a s [uneEof, exCh 'a'] + s = abcRow a b c + +-- We omit tests for 'eof' here because it's used virtually everywhere, it's +-- already thoroughly tested. + +prop_token :: String -> Property +prop_token s = checkParser p r s + where p = token updatePosChar testChar + testChar x = if isLetter x + then Right x + else Left . pure . Unexpected . showToken $ x + h = head s + r | null s = posErr 0 s [uneEof] + | isLetter h && length s == 1 = Right (head s) + | isLetter h && length s > 1 = posErr 1 s [uneCh (s !! 1), exEof] + | otherwise = posErr 0 s [uneCh h] + +prop_tokens :: String -> String -> Property +prop_tokens a = checkString p a (==) (showToken a) + where p = tokens updatePosString (==) a + +-- Parser state combinators + +prop_state_pos :: SourcePos -> Property +prop_state_pos pos = p /=\ pos + where p = setPosition pos >> getPosition + +prop_state_input :: String -> Property +prop_state_input s = p /=\ s + where p = do + st0 <- getInput + guard (null st0) + setInput s + result <- string s + st1 <- getInput + guard (null st1) + return result + +prop_state_tab :: Int -> Property +prop_state_tab w = p /=\ w + where p = setTabWidth w >> getTabWidth + +prop_state :: State String -> State String -> Property +prop_state s1 s2 = runParser p "" "" === Right (f s2 s1) + where f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w + p = do + st <- getParserState + guard (st == State "" (initialPos "") defaultTabWidth) + setParserState s1 + updateParserState (f s2) + getParserState + +-- IdentityT instance of MonadParsec + +prop_IdentityT_try :: String -> String -> String -> Property +prop_IdentityT_try pre s1' s2' = checkParser (runIdentityT p) r s + where s1 = pre ++ s1' + 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] + s = pre + +prop_IdentityT_notFollowedBy :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_IdentityT_notFollowedBy a' b' c' = checkParser (runIdentityT p) r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'a') <* notFollowedBy eof <* many anyChar + r | b > 0 || c > 0 = Right (replicate a 'a') + | otherwise = posErr a s [uneEof, exCh 'a'] + s = abcRow a b c + +-- ReaderT instance of MonadParsec + +prop_ReaderT_try :: String -> String -> String -> Property +prop_ReaderT_try pre s1' s2' = checkParser (runReaderT p (s1', s2')) r s + where s1 = pre ++ s1' + s2 = pre ++ s2' + getS1 = asks ((pre ++) . fst) + 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] + s = pre + +prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> Property +prop_ReaderT_notFollowedBy a' b' c' = checkParser (runReaderT p 'a') r s + where [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char =<< ask) <* notFollowedBy eof <* many anyChar + r | b > 0 || c > 0 = Right (replicate a 'a') + | otherwise = posErr a s [uneEof, exCh 'a'] + s = abcRow a b c + +-- StateT instance of MonadParsec + +prop_StateT_alternative :: Integer -> Property +prop_StateT_alternative n = checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" + where p = L.put n >> ((L.modify (* 2) >> + void (string "xxx")) <|> return ()) >> L.get + p' = S.put n >> ((S.modify (* 2) >> + void (string "xxx")) <|> return ()) >> S.get + +prop_StateT_lookAhead :: Integer -> Property +prop_StateT_lookAhead n = checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" + where p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get + p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get + +prop_StateT_notFollowedBy :: Integer -> Property +prop_StateT_notFollowedBy n = checkParser (L.runStateT p 0) r "abx" .&&. + checkParser (S.runStateT p' 0) r "abx" + where p = do + L.put n + let notEof = notFollowedBy (L.modify (* 2) >> eof) + some (try (anyChar <* notEof)) <* char 'x' + p' = do + S.put n + let notEof = notFollowedBy (S.modify (* 2) >> eof) + some (try (anyChar <* notEof)) <* char 'x' + r = Right ("ab", n) + +-- WriterT instance of MonadParsec + +prop_WriterT :: String -> String -> Property +prop_WriterT pre post = checkParser (L.runWriterT p) r "abx" .&&. + checkParser (S.runWriterT p') r "abx" + where logged_letter = letterChar >>= \x -> L.tell [x] >> return x + logged_letter' = letterChar >>= \x -> L.tell [x] >> return x + logged_eof = eof >> L.tell "EOF" + logged_eof' = eof >> L.tell "EOF" + p = do + L.tell pre + cs <- L.censor (fmap toUpper) $ + some (try (logged_letter <* notFollowedBy logged_eof)) + L.tell post + void logged_letter + return cs + p' = do + L.tell pre + cs <- L.censor (fmap toUpper) $ + some (try (logged_letter' <* notFollowedBy logged_eof')) + L.tell post + void logged_letter' + return cs + r = Right ("ab", pre ++ "AB" ++ post ++ "x") diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,195 @@ +-- -*- Mode: Haskell; -*- +-- +-- QuickCheck tests for Megaparsec, utility functions for parser testing. +-- +-- Copyright © 2015 Megaparsec contributors +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any +-- express or implied warranties, including, but not limited to, the implied +-- warranties of merchantability and fitness for a particular purpose are +-- disclaimed. In no event shall the copyright holders be liable for any +-- direct, indirect, incidental, special, exemplary, or consequential +-- damages (including, but not limited to, procurement of substitute goods +-- or services; loss of use, data, or profits; or business interruption) +-- however caused and on any theory of liability, whether in contract, +-- strict liability, or tort (including negligence or otherwise) arising in +-- any way out of the use of this software, even if advised of the +-- possibility of such damage. + +module Util + ( checkParser + , simpleParse + , checkChar + , checkString + , (/=\) + , abcRow + , abcRow' + , posErr + , uneCh + , uneStr + , uneSpec + , uneEof + , exCh + , exStr + , exSpec + , exEof + , msg + , showToken ) +where + +import Data.Maybe (maybeToList) + +import Test.QuickCheck + +import Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.ShowToken +import Text.Megaparsec.String + +-- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse +-- entire @s@. Result of the parsing is compared with expected result @r@, +-- it should match, otherwise the property doesn't hold and the test fails. + +checkParser :: (Eq a, Show a) + => Parser a -> Either ParseError a -> String -> Property +checkParser p r s = simpleParse p s === r + +-- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding +-- result of type @Either ParseError a@, where @a@ is type of parsed +-- value. This parser tries to parser end of file too and name of input file +-- is always empty string. + +simpleParse :: Parser a -> String -> Either ParseError a +simpleParse p = parse (p <* eof) "" + +-- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if +-- the parser correctly parses single character that satisfies @test@. The +-- character may be labelled, in this case @label@ is used to check quality +-- of error messages. + +checkChar :: Parser Char -> (Char -> Bool) + -> Maybe String -> String -> Property +checkChar p f l' s = checkParser p r s + where h = head s + l = exSpec <$> maybeToList l' + r | null s = posErr 0 s (uneEof : l) + | length s == 1 && f h = Right h + | not (f h) = posErr 0 s (uneCh h : l) + | otherwise = posErr 1 s [uneCh (s !! 1), exEof] + +-- | @checkString p a test label s@ runs parser @p@ on input @s@ and checks if +-- the result is equal to @a@ and also quality of error messages. @test@ is +-- used to compare tokens. @label@ is used as expected representation of +-- parser's result in error messages. + +checkString :: Parser String -> String -> (Char -> Char -> Bool) + -> String -> String -> Property +checkString p a' test l s' = checkParser p (w a' 0 s') s' + where w [] _ [] = Right a' + w [] i (s:_) = posErr i s' [uneCh s, exEof] + w _ 0 [] = posErr 0 s' [uneEof, exSpec l] + w _ i [] = posErr 0 s' [uneStr (take i s'), exSpec l] + w (a:as) i (s:ss) + | test a s = w as i' ss + | otherwise = posErr 0 s' [uneStr (take i' s'), exSpec l] + where i' = succ i + +infix 4 /=\ + +-- | @p /=\\ x@ runs parser @p@ on empty input and compares its result +-- (which should be successful) with @x@. Succeeds when the result is equal +-- to @x@, prints counterexample on failure. + +(/=\) :: (Eq a, Show a) => Parser a -> a -> Property +p /=\ x = simpleParse p "" === Right x + +-- | @abcRow a b c@ generates string consisting of character “a” repeated +-- @a@ times, character “b” repeated @b@ times, and finally character “c” +-- repeated @c@ times. + +abcRow :: Int -> Int -> Int -> String +abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' + +-- | @abcRow' a b c@ generates string that includes character “a” if @a@ is +-- 'True', then optionally character “b” if @b@ is 'True', then character +-- “c” if @c@ is 'True'. + +abcRow' :: Bool -> Bool -> Bool -> String +abcRow' a b c = abcRow (fromEnum a) (fromEnum b) (fromEnum c) + +-- | @posErr pos s ms@ is an easy way to model result of parser that +-- fails. @pos@ is how many tokens (characters) has been consumed before +-- failure. @s@ is input of the parser. @ms@ is a list, collection of +-- 'Message's. See 'uneStr', 'uneCh', 'uneSpec', 'exStr', 'exCh', and +-- 'exSpec' for easy ways to create error messages. + +posErr :: Int -> String -> [Message] -> Either ParseError a +posErr pos s = Left . foldr addErrorMessage (newErrorUnknown errPos) + where errPos = updatePosString defaultTabWidth (initialPos "") (take pos s) + +-- | @uneCh s@ returns message created with 'Unexpected' constructor that +-- tells the system that char @s@ is unexpected. + +uneCh :: Char -> Message +uneCh s = Unexpected $ showToken s + +-- | @uneStr s@ returns message created with 'Unexpected' constructor that +-- tells the system that string @s@ is unexpected. + +uneStr :: String -> Message +uneStr s = Unexpected $ showToken s + +-- | @uneSpec s@ returns message created with 'Unexpected' constructor that +-- tells the system that @s@ is unexpected. This is different from 'uneStr' +-- in that it doesn't use 'showToken' but rather pass its argument unaltered +-- allowing for “special” labels. + +uneSpec :: String -> Message +uneSpec = Unexpected + +-- | @uneEof@ represents message “unexpected end of input”. + +uneEof :: Message +uneEof = Unexpected "end of input" + +-- | @exCh s@ returns message created with 'Expected' constructor that tells +-- the system that character @s@ is expected. + +exCh :: Char -> Message +exCh s = Expected $ showToken s + +-- | @exStr s@ returns message created with 'Expected' constructor that tells +-- the system that string @s@ is expected. + +exStr :: String -> Message +exStr s = Expected $ showToken s + +-- | @exSpec s@ returns message created with 'Expected' constructor that tells +-- the system that @s@ is expected. This is different from 'exStr' in that +-- it doesn't use 'showToken' but rather pass its argument unaltered +-- allowing for “special” labels. + +exSpec :: String -> Message +exSpec = Expected + +-- | @exEof@ represents message “expecting end of input”. + +exEof :: Message +exEof = Expected "end of input" + +-- | @msg s@ return message created with 'Message' constructor. + +msg :: String -> Message +msg = Message