packages feed

megaparsec (empty) → 4.0.0

raw patch · 39 files changed

+5497/−0 lines, 39 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, criterion, megaparsec, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers

Files

+ AUTHORS.md view
@@ -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
+ CHANGELOG.md view
@@ -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.
+ LICENSE.md view
@@ -0,0 +1,25 @@+Copyright © 2015 Megaparsec contributors<br>+Copyright © 2007 Paolo Martini<br>+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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Text/Megaparsec.hs view
@@ -0,0 +1,190 @@+-- |+-- Module      :  Text.Megaparsec+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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.
+ Text/Megaparsec/ByteString.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      :  Text.Megaparsec.ByteString+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/ByteString/Lazy.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      :  Text.Megaparsec.ByteString.Lazy+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Char.hs view
@@ -0,0 +1,341 @@+-- |+-- Module      :  Text.Megaparsec.Char+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Combinator.hs view
@@ -0,0 +1,238 @@+-- |+-- Module      :  Text.Megaparsec.Combinator+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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 "<!--" >> manyTill anyChar (try $ 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 #-}
+ Text/Megaparsec/Error.hs view
@@ -0,0 +1,183 @@+-- |+-- Module      :  Text.Megaparsec.Error+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Expr.hs view
@@ -0,0 +1,144 @@+-- |+-- Module      :  Text.Megaparsec.Expr+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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)
+ Text/Megaparsec/Lexer.hs view
@@ -0,0 +1,281 @@+-- |+-- Module      :  Text.Megaparsec.Lexer+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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)
+ Text/Megaparsec/Perm.hs view
@@ -0,0 +1,123 @@+-- |+-- Module      :  Text.Megaparsec.Perm+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Pos.hs view
@@ -0,0 +1,129 @@+-- |+-- Module      :  Text.Megaparsec.Pos+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Prim.hs view
@@ -0,0 +1,785 @@+-- |+-- Module      :  Text.Megaparsec.Prim+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+--                © 1999–2001 Daan Leijen+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/ShowToken.hs view
@@ -0,0 +1,53 @@+-- |+-- Module      :  Text.Megaparsec.ShowToken+-- Copyright   :  © 2015 Megaparsec contributors+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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 ++ "\""
+ Text/Megaparsec/String.hs view
@@ -0,0 +1,39 @@+-- |+-- Module      :  Text.Megaparsec.String+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2007 Paolo Martini+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Text.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      :  Text.Megaparsec.Text+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2011 Antoine Latter+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ Text/Megaparsec/Text/Lazy.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      :  Text.Megaparsec.Text.Lazy+-- Copyright   :  © 2015 Megaparsec contributors+--                © 2011 Antoine Latter+-- License     :  BSD3+--+-- Maintainer  :  Mark Karpov <markkarpov@opmbx.org>+-- 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
+ benchmarks/Main.hs view
@@ -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")
+ megaparsec.cabal view
@@ -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 <paolo@nemail.it>,+                     Daan Leijen <daan@microsoft.com>++maintainer:          Mark Karpov <markkarpov@opmbx.org>+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
+ old-tests/Bugs.hs view
@@ -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 ]
+ old-tests/Bugs/Bug2.hs view
@@ -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
+ old-tests/Bugs/Bug35.hs view
@@ -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
+ old-tests/Bugs/Bug39.hs view
@@ -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
+ old-tests/Bugs/Bug6.hs view
@@ -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
+ old-tests/Bugs/Bug9.hs view
@@ -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 ">>>") ]]
+ old-tests/Main.hs view
@@ -0,0 +1,7 @@++import Test.Framework++import Bugs (bugs)++main :: IO ()+main = defaultMain [testGroup "Bugs" bugs]
+ old-tests/Util.hs view
@@ -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 _  -> []
+ tests/Char.hs view
@@ -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
+ tests/Combinator.hs view
@@ -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
+ tests/Error.hs view
@@ -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)
+ tests/Expr.hs view
@@ -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)
+ tests/Lexer.hs view
@@ -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
+ tests/Main.hs view
@@ -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 ]
+ tests/Perm.hs view
@@ -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
+ tests/Pos.hs view
@@ -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
+ tests/Prim.hs view
@@ -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")
+ tests/Util.hs view
@@ -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