megaparsec-5.0.1/Text/0000755000000000000000000000000012740660546012750 5ustar0000000000000000megaparsec-5.0.1/Text/Megaparsec/0000755000000000000000000000000012740673060015012 5ustar0000000000000000megaparsec-5.0.1/Text/Megaparsec/ByteString/0000755000000000000000000000000012731614722017104 5ustar0000000000000000megaparsec-5.0.1/Text/Megaparsec/Text/0000755000000000000000000000000012731614722015736 5ustar0000000000000000megaparsec-5.0.1/benchmarks/0000755000000000000000000000000012740653245014137 5ustar0000000000000000megaparsec-5.0.1/old-tests/0000755000000000000000000000000012731614724013737 5ustar0000000000000000megaparsec-5.0.1/old-tests/Bugs/0000755000000000000000000000000012731614724014637 5ustar0000000000000000megaparsec-5.0.1/tests/0000755000000000000000000000000012731614724013163 5ustar0000000000000000megaparsec-5.0.1/Text/Megaparsec.hs0000644000000000000000000001073112715565464015362 0ustar0000000000000000-- | -- Module : Text.Megaparsec -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- This module includes everything you need to get started writing a parser. -- If you are new to Megaparsec and don't know where to begin, take a look -- at our tutorials . -- -- By default this module is set up to parse character data. If you'd like to -- parse the result of your own tokenizer you should start with the following -- imports: -- -- > import Text.Megaparsec.Prim -- > import Text.Megaparsec.Combinator -- -- Then you can implement your own version of 'satisfy' on top of the -- 'token' primitive. -- -- 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@. -- -- Megaparsec is capable of a lot. Apart from this standard functionality -- you can parse permutation phrases with "Text.Megaparsec.Perm", -- expressions with "Text.Megaparsec.Expr", and even entire languages with -- "Text.Megaparsec.Lexer". These modules should be imported explicitly -- along with the two modules mentioned above. module Text.Megaparsec ( -- * Running parser Parsec , ParsecT , runParser , runParser' , runParserT , runParserT' , parse , parseMaybe , parseTest -- * Combinators , (A.<|>) -- $assocbo , A.many -- $many , A.some -- $some , A.optional -- $optional , unexpected , failure , () , label , hidden , try , lookAhead , notFollowedBy , withRecovery , eof , token , tokens , between , choice , count , count' , eitherP , endBy , endBy1 , manyTill , someTill , option , sepBy , sepBy1 , sepEndBy , sepEndBy1 , skipMany , skipSome -- * Character parsing , newline , crlf , eol , tab , space , controlChar , spaceChar , upperChar , lowerChar , letterChar , alphaNumChar , printChar , digitChar , octDigitChar , hexDigitChar , markChar , numberChar , punctuationChar , symbolChar , separatorChar , asciiChar , latin1Char , charCategory , char , char' , anyChar , oneOf , oneOf' , noneOf , noneOf' , satisfy , string , string' -- * Textual source position , Pos , mkPos , unPos , unsafePos , InvalidPosException (..) , SourcePos (..) , initialPos , sourcePosPretty -- * Error messages , ErrorItem (..) , ErrorComponent (..) , Dec (..) , ParseError (..) , ShowToken (..) , ShowErrorComponent (..) , parseErrorPretty -- * Low-level operations , Stream (..) , State (..) , getInput , setInput , getPosition , setPosition , pushPosition , popPosition , 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. megaparsec-5.0.1/Text/Megaparsec/ByteString.hs0000644000000000000000000000131512710173312017430 0ustar0000000000000000-- | -- Module : Text.Megaparsec.ByteString -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Convenience definitions for working with strict 'ByteString'. module Text.Megaparsec.ByteString (Parser) where import Data.ByteString import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim -- | Modules corresponding to various types of streams define 'Parser' -- accordingly, so user can use it to easily change type of input stream by -- importing different “type modules”. This one is for strict byte-strings. type Parser = Parsec Dec ByteString megaparsec-5.0.1/Text/Megaparsec/ByteString/Lazy.hs0000644000000000000000000000133012710173312020344 0ustar0000000000000000-- | -- Module : Text.Megaparsec.ByteString.Lazy -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Convenience definitions for working with lazy 'ByteString'. module Text.Megaparsec.ByteString.Lazy (Parser) where import Data.ByteString.Lazy import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim -- | Modules corresponding to various types of streams define 'Parser' -- accordingly, so user can use it to easily change type of input stream by -- importing different “type modules”. This one is for lazy byte-strings. type Parser = Parsec Dec ByteString megaparsec-5.0.1/Text/Megaparsec/Char.hs0000644000000000000000000003127212711576144016233 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Char -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : non-portable -- -- Commonly used character parsers. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} 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.NonEmpty (NonEmpty (..)) import Data.Maybe (fromJust) import qualified Data.Set as E import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Prim #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), pure) import Data.Foldable (Foldable (), any, elem, notElem) import Prelude hiding (any, elem, notElem) #endif ---------------------------------------------------------------------------- -- Simple parsers -- | Parses a newline character. newline :: (MonadParsec e s m, Token s ~ Char) => m Char newline = char '\n' {-# INLINE newline #-} -- | Parses a carriage return character followed by a newline character. -- Returns sequence of characters parsed. crlf :: (MonadParsec e s m, Token s ~ Char) => m String crlf = string "\r\n" {-# INLINE crlf #-} -- | Parses a CRLF (see 'crlf') or LF (see 'newline') end of line. Returns -- the sequence of characters parsed. -- -- > eol = (pure <$> newline) <|> crlf eol :: (MonadParsec e s m, Token s ~ Char) => m String eol = (pure <$> newline) <|> crlf "end of line" {-# INLINE eol #-} -- | Parses a tab character. tab :: (MonadParsec e s m, Token s ~ Char) => m Char tab = char '\t' {-# INLINE tab #-} -- | Skips /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. space :: (MonadParsec e s m, Token s ~ Char) => m () space = skipMany spaceChar {-# INLINE space #-} ---------------------------------------------------------------------------- -- Categories of characters -- | Parses control characters, which are the non-printing characters of the -- Latin-1 subset of Unicode. controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char controlChar = satisfy isControl "control character" {-# INLINE controlChar #-} -- | Parses a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. spaceChar :: (MonadParsec e s m, Token s ~ Char) => m Char spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} -- | 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 e s m, Token s ~ Char) => m Char upperChar = satisfy isUpper "uppercase letter" {-# INLINE upperChar #-} -- | Parses a lower-case alphabetic Unicode character. lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char lowerChar = satisfy isLower "lowercase letter" {-# INLINE lowerChar #-} -- | Parses alphabetic Unicode characters: lower-case, upper-case and -- title-case letters, plus letters of case-less scripts and modifiers -- letters. letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char letterChar = satisfy isLetter "letter" {-# INLINE letterChar #-} -- | 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 e s m, Token s ~ Char) => m Char alphaNumChar = satisfy isAlphaNum "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parses printable Unicode characters: letters, numbers, marks, -- punctuation, symbols and spaces. printChar :: (MonadParsec e s m, Token s ~ Char) => m Char printChar = satisfy isPrint "printable character" {-# INLINE printChar #-} -- | Parses an ASCII digit, i.e between “0” and “9”. digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char digitChar = satisfy isDigit "digit" {-# INLINE digitChar #-} -- | Parses an octal digit, i.e. between “0” and “7”. octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char octDigitChar = satisfy isOctDigit "octal digit" {-# INLINE octDigitChar #-} -- | Parses a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, -- or “A” and “F”. hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char hexDigitChar = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parses Unicode mark characters, for example accents and the like, which -- combine with preceding characters. markChar :: (MonadParsec e s m, Token s ~ Char) => m Char markChar = satisfy isMark "mark character" {-# INLINE markChar #-} -- | Parses Unicode numeric characters, including digits from various -- scripts, Roman numerals, et cetera. numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char numberChar = satisfy isNumber "numeric character" {-# INLINE numberChar #-} -- | Parses Unicode punctuation characters, including various kinds of -- connectors, brackets and quotes. punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m Char punctuationChar = satisfy isPunctuation "punctuation" {-# INLINE punctuationChar #-} -- | Parses Unicode symbol characters, including mathematical and currency -- symbols. symbolChar :: (MonadParsec e s m, Token s ~ Char) => m Char symbolChar = satisfy isSymbol "symbol" {-# INLINE symbolChar #-} -- | Parses Unicode space and separator characters. separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char separatorChar = satisfy isSeparator "separator" {-# INLINE separatorChar #-} -- | Parses a character from the first 128 characters of the Unicode character set, -- corresponding to the ASCII character set. asciiChar :: (MonadParsec e s m, Token s ~ Char) => m Char asciiChar = satisfy isAscii "ASCII character" {-# INLINE asciiChar #-} -- | 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 e s m, Token s ~ Char) => m Char latin1Char = satisfy isLatin1 "Latin-1 character" {-# INLINE latin1Char #-} -- | @charCategory cat@ Parses character in Unicode General Category @cat@, -- see 'Data.Char.GeneralCategory'. charCategory :: (MonadParsec e s m, Token s ~ Char) => GeneralCategory -> m Char charCategory cat = satisfy ((== cat) . generalCategory) categoryName cat {-# INLINE charCategory #-} -- | 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") ] ---------------------------------------------------------------------------- -- More general parsers -- | @char c@ parses a single character @c@. -- -- > semicolon = char ';' char :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char char c = token testChar (Just c) where f x = E.singleton (Tokens (x:|[])) testChar x = if x == c then Right x else Left (f x, f c, E.empty) {-# INLINE char #-} -- | 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" -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' char' :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char char' c = choice [char c, char $ swapCase c] where swapCase x | isUpper x = toLower x | isLower x = toUpper x | otherwise = x {-# INLINE char' #-} -- | This parser succeeds for any character. Returns the parsed character. anyChar :: (MonadParsec e s m, Token s ~ Char) => m Char anyChar = satisfy (const True) "character" {-# INLINE anyChar #-} -- | @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 :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char oneOf cs = satisfy (`elem` cs) {-# INLINE oneOf #-} -- | The same as 'oneOf', but case-insensitive. Returns the parsed character -- preserving its case. -- -- > vowel = oneOf' "aeiou" "vowel" oneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char oneOf' cs = satisfy (`elemi` cs) {-# INLINE oneOf' #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current -- character /not/ in the supplied list of characters @cs@. Returns the -- parsed character. noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char noneOf cs = satisfy (`notElem` cs) {-# INLINE noneOf #-} -- | The same as 'noneOf', but case-insensitive. -- -- > consonant = noneOf' "aeiou" "consonant" noneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char noneOf' cs = satisfy (`notElemi` cs) {-# INLINE noneOf' #-} -- | The parser @satisfy f@ succeeds for any character for which the -- supplied function @f@ returns 'True'. Returns the character that is -- actually parsed. -- -- > digitChar = satisfy isDigit "digit" -- > oneOf cs = satisfy (`elem` cs) satisfy :: (MonadParsec e s m, Token s ~ Char) => (Char -> Bool) -> m Char satisfy f = token testChar Nothing where testChar x = if f x then Right x else Left (E.singleton (Tokens (x:|[])), E.empty, E.empty) {-# INLINE satisfy #-} ---------------------------------------------------------------------------- -- Sequence of characters -- | @string s@ parses a sequence of characters given by @s@. Returns -- the parsed string (i.e. @s@). -- -- > divOrMod = string "div" <|> string "mod" string :: (MonadParsec e s m, Token s ~ Char) => String -> m String string = tokens (==) {-# INLINE string #-} -- | The same as 'string', but case-insensitive. On success returns string -- cased as actually parsed input. -- -- >>> parseTest (string' "foobar") "foObAr" -- "foObAr" string' :: (MonadParsec e s m, Token s ~ Char) => String -> m String string' = tokens casei {-# INLINE string' #-} ---------------------------------------------------------------------------- -- Helpers -- | Case-insensitive equality test for characters. casei :: Char -> Char -> Bool casei x y = toLower x == toLower y {-# INLINE casei #-} -- | Case-insensitive 'elem'. elemi :: Foldable f => Char -> f Char -> Bool elemi = any . casei {-# INLINE elemi #-} -- | Case-insensitive 'notElem'. notElemi :: Foldable f => Char -> f Char -> Bool notElemi c = not . elemi c {-# INLINE notElemi #-} megaparsec-5.0.1/Text/Megaparsec/Combinator.hs0000644000000000000000000001235312710173312017437 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Combinator -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Commonly used generic combinators. Note that all combinators works with -- any 'Alternative' instances. {-# LANGUAGE CPP #-} module Text.Megaparsec.Combinator ( between , choice , count , count' , eitherP , endBy , endBy1 , manyTill , someTill , option , sepBy , sepBy1 , sepEndBy , sepEndBy1 , skipMany , skipSome ) where import Control.Applicative import Control.Monad (void) import Data.Foldable (asum) #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable) import Data.Traversable (sequenceA) #endif -- | @between open close p@ parses @open@, followed by @p@ and @close@. -- Returns the value returned by @p@. -- -- > braces = between (symbol "{") (symbol "}") between :: Applicative m => m open -> m close -> m a -> m a between open close p = open *> p <* close {-# INLINE between #-} -- | @choice ps@ tries to apply the parsers in the list @ps@ in order, -- until one of them succeeds. Returns the value of the succeeding parser. choice :: (Foldable f, Alternative m) => f (m a) -> m a choice = asum {-# INLINE choice #-} -- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or -- equal to zero, the parser equals to @return []@. Returns a list of @n@ -- values. count :: Applicative m => Int -> m a -> m [a] count n p | n <= 0 = pure [] | otherwise = sequenceA (replicate n p) {-# INLINE count #-} -- | @count\' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is -- not positive or @m > n@, the parser equals to @return []@. Returns a list -- of parsed values. -- -- Please note that @m@ /may/ be negative, in this case effect is the same -- as if it were equal to zero. count' :: Alternative m => Int -> Int -> m a -> m [a] count' m n p | 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 -- | Combine two alternatives. -- -- @since 4.4.0 eitherP :: Alternative m => m a -> m b -> m (Either a b) eitherP a b = (Left <$> a) <|> (Right <$> b) {-# INLINE eitherP #-} -- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. -- -- > cStatements = cStatement `endBy` semicolon endBy :: Alternative m => m a -> m sep -> m [a] endBy p sep = many (p <* sep) {-# INLINE endBy #-} -- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. endBy1 :: Alternative m => m a -> m sep -> m [a] endBy1 p sep = some (p <* sep) {-# INLINE endBy1 #-} -- | @manyTill p end@ applies parser @p@ /zero/ or more times until -- parser @end@ succeeds. Returns the list of values returned by @p@. This -- parser can be used to scan comments: -- -- > simpleComment = string "") manyTill :: Alternative m => m a -> m end -> m [a] manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) {-# INLINE manyTill #-} -- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should -- succeed at least once. someTill :: Alternative m => m a -> m end -> m [a] someTill p end = (:) <$> p <*> manyTill p end {-# INLINE someTill #-} -- | @option x p@ tries to apply parser @p@. If @p@ fails without -- consuming input, it returns the value @x@, otherwise the value returned -- by @p@. -- -- > priority = option 0 (digitToInt <$> digitChar) option :: Alternative m => a -> m a -> m a option x p = p <|> pure x {-# INLINE option #-} -- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated -- by @sep@. Returns a list of values returned by @p@. -- -- > commaSep p = p `sepBy` comma sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = sepBy1 p sep <|> pure [] {-# INLINE sepBy #-} -- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated -- by @sep@. Returns a list of values returned by @p@. sepBy1 :: Alternative m => m a -> m sep -> m [a] sepBy1 p sep = (:) <$> p <*> many (sep *> p) {-# INLINE sepBy1 #-} -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a list of values -- returned by @p@. sepEndBy :: Alternative m => m a -> m sep -> m [a] sepEndBy p sep = sepEndBy1 p sep <|> pure [] {-# INLINE sepEndBy #-} -- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a list of values -- returned by @p@. sepEndBy1 :: Alternative m => m a -> m sep -> m [a] sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) -- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping -- its result. -- -- > space = skipMany spaceChar skipMany :: Alternative m => m a -> m () skipMany p = void $ many p {-# INLINE skipMany #-} -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping -- its result. skipSome :: Alternative m => m a -> m () skipSome p = void $ some p {-# INLINE skipSome #-} megaparsec-5.0.1/Text/Megaparsec/Error.hs0000644000000000000000000002166312740661346016453 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Error -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Parse errors. Current version of Megaparsec supports well-typed errors -- instead of 'String'-based ones. This gives a lot of flexibility in -- describing what exactly went wrong as well as a way to return arbitrary -- data in case of failure. {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Text.Megaparsec.Error ( ErrorItem (..) , ErrorComponent (..) , Dec (..) , ParseError (..) , ShowToken (..) , ShowErrorComponent (..) , parseErrorPretty , sourcePosStackPretty ) where import Control.DeepSeq import Control.Monad.Catch import Data.Data (Data) import Data.Foldable (concat) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Generics import Prelude hiding (concat) import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import Text.Megaparsec.Pos #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -- | Data type that is used to represent “unexpected\/expected” items in -- parse error. The data type is parametrized over token type @t@. -- -- @since 5.0.0 data ErrorItem t = Tokens (NonEmpty t) -- ^ Non-empty stream of tokens | Label (NonEmpty Char) -- ^ Label (cannot be empty) | EndOfInput -- ^ End of input deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) instance NFData t => NFData (ErrorItem t) -- | The type class defines how to represent information about various -- exceptional situations. Data types that are used as custom data component -- in 'ParseError' must be instances of this type class. -- -- @since 5.0.0 class Ord e => ErrorComponent e where -- | Represent message passed to 'fail' in parser monad. -- -- @since 5.0.0 representFail :: String -> e -- | Represent information about incorrect indentation. -- -- @since 5.0.0 representIndentation :: Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> Pos -- ^ Actual indentation level -> e -- | “Default error component”. This in our instance of 'ErrorComponent' -- provided out-of-box. -- -- @since 5.0.0 data Dec = DecFail String -- ^ 'fail' has been used in parser monad | DecIndentation Ordering Pos Pos -- ^ Incorrect indentation error: desired ordering between reference -- level and actual level, reference indentation level, actual -- indentation level deriving (Show, Read, Eq, Ord, Data, Typeable) instance NFData Dec where rnf (DecFail str) = rnf str rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act instance ErrorComponent Dec where representFail = DecFail representIndentation = DecIndentation -- | The data type @ParseError@ represents parse errors. It provides the -- stack of source positions, set of expected and unexpected tokens as well -- as set of custom associated data. The data type is parametrized over -- token type @t@ and custom data @e@. -- -- Note that stack of source positions contains current position as its -- head, and the rest of positions allows to track full sequence of include -- files with topmost source file at the end of the list. -- -- 'Semigroup' (or 'Monoid') instance of the data type allows to merge parse -- errors from different branches of parsing. When merging two -- 'ParseError's, longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. data ParseError t e = ParseError { errorPos :: NonEmpty SourcePos -- ^ Stack of source positions , errorUnexpected :: Set (ErrorItem t) -- ^ Unexpected items , errorExpected :: Set (ErrorItem t) -- ^ Expected items , errorCustom :: Set e -- ^ Associated data, if any } deriving (Show, Read, Eq, Data, Typeable, Generic) instance (NFData t, NFData e) => NFData (ParseError t e) instance (Ord t, Ord e) => Semigroup (ParseError t e) where (<>) = mergeError {-# INLINE (<>) #-} instance (Ord t, Ord e) => Monoid (ParseError t e) where mempty = ParseError (initialPos "" :| []) E.empty E.empty E.empty mappend = (<>) {-# INLINE mappend #-} instance (Show t, Typeable t, Show e, Typeable e) => Exception (ParseError t e) -- | Merge two error data structures into one joining their collections of -- message items 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 :: (Ord t, Ord e) => ParseError t e -> ParseError t e -> ParseError t e mergeError e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) = case pos1 `compare` pos2 of LT -> e2 EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2) GT -> e1 {-# INLINE mergeError #-} -- | Type class 'ShowToken' includes methods that allow to pretty-print -- single token as well as stream of tokens. This is used for rendering of -- error messages. class ShowToken a where -- | Pretty-print non-empty stream of tokens. This function is also used -- to print single tokens (represented as singleton lists). -- -- @since 5.0.0 showTokens :: NonEmpty a -> String instance ShowToken Char where showTokens = stringPretty -- | @stringPretty s@ returns pretty representation of string @s@. This is -- used when printing string tokens in error messages. stringPretty :: NonEmpty Char -> String stringPretty (x:|[]) = charPretty x stringPretty ('\r':|"\n") = "crlf newline" stringPretty xs = "\"" ++ NE.toList xs ++ "\"" -- | @charPretty ch@ returns user-friendly string representation of given -- character @ch@, suitable for using in error messages. charPretty :: Char -> String charPretty '\0' = "null" charPretty '\a' = "bell" charPretty '\b' = "backspace" charPretty '\t' = "tab" charPretty '\n' = "newline" charPretty '\v' = "vertical tab" charPretty '\f' = "form feed" charPretty '\r' = "carriage return" charPretty ' ' = "space" charPretty x = "'" ++ [x] ++ "'" -- | The type class defines how to print custom data component of -- 'ParseError'. -- -- @since 5.0.0 class Ord a => ShowErrorComponent a where -- | Pretty-print custom data component of 'ParseError'. showErrorComponent :: a -> String instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where showErrorComponent (Tokens ts) = showTokens ts showErrorComponent (Label label) = NE.toList label showErrorComponent EndOfInput = "end of input" instance ShowErrorComponent Dec where showErrorComponent (DecFail msg) = msg showErrorComponent (DecIndentation ord ref actual) = "incorrect indentation (got " ++ show (unPos actual) ++ ", should be " ++ p ++ show (unPos ref) ++ ")" where p = case ord of LT -> "less than " EQ -> "equal to " GT -> "greater than " -- | Pretty-print 'ParseError'. Note that rendered 'String' always ends with -- a newline. -- -- @since 5.0.0 parseErrorPretty :: ( Ord t , ShowToken t , ShowErrorComponent e ) => ParseError t e -- ^ Parse error to render -> String -- ^ Result of rendering parseErrorPretty (ParseError pos us ps xs) = sourcePosStackPretty pos ++ ":\n" ++ if E.null us && E.null ps && E.null xs then "unknown parse error\n" else concat [ messageItemsPretty "unexpected " us , messageItemsPretty "expecting " ps , unlines (showErrorComponent <$> E.toAscList xs) ] -- | Pretty-print stack of source positions. -- -- @since 5.0.0 sourcePosStackPretty :: NonEmpty SourcePos -> String sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos where (pos :| rest') = ms rest = reverse rest' f p = "in file included from " ++ sourcePosPretty p ++ ",\n" -- | Transforms list of error messages into their textual representation. messageItemsPretty :: ShowErrorComponent a => String -- ^ Prefix to prepend -> Set a -- ^ Collection of messages -> String -- ^ Result of rendering messageItemsPretty prefix ts | E.null ts = "" | otherwise = let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent in prefix ++ f ts ++ "\n" -- | Print a pretty list where items are separated with commas and the word -- “or” according to rules of English punctuation. orList :: NonEmpty String -> String orList (x:|[]) = x orList (x:|[y]) = x ++ " or " ++ y orList xs = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs megaparsec-5.0.1/Text/Megaparsec/Expr.hs0000644000000000000000000001263312733036407016271 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Expr -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : non-portable -- -- A helper module to parse expressions. It can build a parser given a table -- of operators. module Text.Megaparsec.Expr ( Operator (..) , makeExprParser ) where import 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 m a]@ lists. The list is ordered in -- descending precedence. All operators in one list have the same precedence -- (but may have different associativity). -- -- Prefix and postfix operators of the same precedence associate to the left -- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). -- -- Unary operators of the same precedence can only occur once (i.e. @--2@ is -- not allowed if @-@ is prefix negate). If you need to parse several prefix -- or postfix operators in a row, (like C pointers — @**i@) you can use this -- approach: -- -- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp -- -- This is not done by default because in some cases you don't want to allow -- repeating prefix or postfix operators. -- -- @makeExprParser@ takes care of all the complexity involved in building an -- expression parser. Here is an example of an expression parser that -- handles prefix signs, postfix increment and basic arithmetic: -- -- > expr = makeExprParser term table "expression" -- > -- > term = parens expr <|> integer "term" -- > -- > table = [ [ prefix "-" negate -- > , prefix "+" id ] -- > , [ postfix "++" (+1) ] -- > , [ binary "*" (*) -- > , binary "/" div ] -- > , [ binary "+" (+) -- > , binary "-" (-) ] ] -- > -- > binary name f = InfixL (f <$ symbol name) -- > prefix name f = Prefix (f <$ symbol name) -- > postfix name f = Postfix (f <$ symbol name) makeExprParser :: MonadParsec e s m => m a -- ^ Term parser -> [[Operator m a]] -- ^ Operator table, see 'Operator' -> m a -- ^ Resulting expression parser makeExprParser = foldl addPrecLevel -- | @addPrecLevel p ops@ adds ability to parse operators in table @ops@ to -- parser @p@. addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a addPrecLevel term ops = term' >>= \x -> choice [ras' x, las' x, nas' x, return x] "operator" where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops term' = pTerm (choice prefix) term (choice postfix) ras' = pInfixR (choice ras) term' las' = pInfixL (choice las) term' nas' = pInfixN (choice nas) term' -- | @pTerm prefix term postfix@ parses 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 e s m => m (a -> a) -> m a -> m (a -> a) -> m a pTerm prefix term postfix = do pre <- option id (hidden prefix) x <- term post <- option id (hidden postfix) return . post . pre $ x -- | @pInfixN op p x@ parses non-associative infix operator @op@, then term -- with parser @p@, then returns result of the operator application on @x@ -- and the term. pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixN op p x = do f <- op y <- p return $ f x y -- | @pInfixL op p x@ parses left-associative infix operator @op@, then term -- with parser @p@, then returns result of the operator application on @x@ -- and the term. pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixL op p x = do f <- op y <- p let r = f x y pInfixL op p r <|> return r -- | @pInfixR op p x@ parses right-associative infix operator @op@, then -- term with parser @p@, then returns result of the operator application on -- @x@ and the term. pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixR op p x = do f <- op y <- p >>= \r -> pInfixR op p r <|> return r return $ f x y type Batch m a = ( [m (a -> a -> a)] , [m (a -> a -> a)] , [m (a -> a -> a)] , [m (a -> a)] , [m (a -> a)] ) -- | A helper to separate various operators (binary, unary, and according to -- associativity) and return them in a tuple. splitOp :: Operator m a -> Batch m a -> Batch m a splitOp (InfixR op) (r, l, n, pre, post) = (op:r, l, n, pre, post) splitOp (InfixL op) (r, l, n, pre, post) = (r, op:l, n, pre, post) splitOp (InfixN op) (r, l, n, pre, post) = (r, l, op:n, pre, post) splitOp (Prefix op) (r, l, n, pre, post) = (r, l, n, op:pre, post) splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post) megaparsec-5.0.1/Text/Megaparsec/Lexer.hs0000644000000000000000000004333612740650106016432 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Lexer -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : non-portable -- -- High-level parsers to help you write your lexer. The module doesn't -- impose how you should write your parser, but certain approaches may be -- more elegant than others. Especially important theme is parsing of white -- space, comments, and indentation. -- -- This module is intended to be imported qualified: -- -- > import qualified Text.Megaparsec.Lexer as L {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.Lexer ( -- * White space space , lexeme , symbol , symbol' , skipLineComment , skipBlockComment , skipBlockCommentNested -- * Indentation , indentLevel , incorrectIndent , indentGuard , nonIndented , IndentOpt (..) , indentBlock , lineFold -- * Character and string literals , charLiteral -- * Numbers , integer , decimal , hexadecimal , octal , scientific , float , number , signed ) where import Control.Applicative ((<|>), some, optional) import Control.Monad (void) import Data.Char (readLitChar) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (listToMaybe, fromMaybe, isJust) import Data.Scientific (Scientific, toRealFloat) import qualified Data.Set as E import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import qualified Text.Megaparsec.Char as C #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (*>), (<*>), pure) #endif ---------------------------------------------------------------------------- -- White space -- | @space spaceChar lineComment blockComment@ produces parser that can -- parse white space in general. It's expected that you create such a parser -- once and pass it to other functions in this module as needed (when you -- see @spaceConsumer@ in documentation, usually it means that something -- like 'space' is expected there). -- -- @spaceChar@ is used to parse trivial space characters. You can use -- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as -- your own parser (if you don't want to automatically consume newlines, for -- example). -- -- @lineComment@ is used to parse line comments. You can use -- 'skipLineComment' if you don't need anything special. -- -- @blockComment@ is used to parse block (multi-line) comments. You can use -- 'skipBlockComment' if you don't need anything special. -- -- Parsing of white space is an important part of any parser. We propose a -- convention where every lexeme parser assumes no spaces before the lexeme -- and consumes all spaces after the lexeme; this is what the 'lexeme' -- combinator does, and so it's enough to wrap every lexeme parser with -- 'lexeme' to achieve this. Note that you'll need to call 'space' manually -- to consume any white space before the first lexeme (i.e. at the beginning -- of the file). space :: MonadParsec e s m => m () -- ^ A parser for a space character (e.g. '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 e s m => m () -- ^ How to consume white space after lexeme -> m a -- ^ How to parse actual lexeme -> m a lexeme spc p = p <* spc -- | This is a helper to parse symbols, i.e. verbatim strings. You pass the -- first argument (parser that consumes white space, probably defined via -- 'space') and then you can use the resulting function to parse strings: -- -- > symbol = L.symbol spaceConsumer -- > -- > parens = between (symbol "(") (symbol ")") -- > braces = between (symbol "{") (symbol "}") -- > angles = between (symbol "<") (symbol ">") -- > brackets = between (symbol "[") (symbol "]") -- > semicolon = symbol ";" -- > comma = symbol "," -- > colon = symbol ":" -- > dot = symbol "." symbol :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume white space after lexeme -> String -- ^ String to parse -> m String symbol spc = lexeme spc . C.string -- | Case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages. symbol' :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume white space after lexeme -> String -- ^ String to parse (case-insensitive) -> m String symbol' spc = lexeme spc . C.string' -- | Given comment prefix this function returns 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 e s m, Token s ~ Char) => String -- ^ Line comment prefix -> m () skipLineComment prefix = p >> void (manyTill C.anyChar n) where p = C.string prefix n = lookAhead C.newline -- | @skipBlockComment start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment :: (MonadParsec e s m, Token s ~ Char) => String -- ^ Start of block comment -> String -- ^ End of block comment -> m () skipBlockComment start end = p >> void (manyTill C.anyChar n) where p = C.string start n = C.string end -- | @skipBlockCommentNested start end@ skips possibly nested block comment -- starting with @start@ and ending with @end@. -- -- @since 5.0.0 skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char) => String -- ^ Start of block comment -> String -- ^ End of block comment -> m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void C.anyChar p = C.string start n = C.string end ---------------------------------------------------------------------------- -- Indentation -- | Return current indentation level. -- -- The function is a simple shortcut defined as: -- -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0 indentLevel :: MonadParsec e s m => m Pos indentLevel = sourceColumn <$> getPosition -- | Fail reporting incorrect indentation error. The error has attached -- information: -- -- * Desired ordering between reference level and actual level -- * Reference indentation level -- * Actual indentation level -- -- @since 5.0.0 incorrectIndent :: MonadParsec e s m => Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> Pos -- ^ Actual indentation level -> m a incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x) where x = representIndentation ord ref actual -- | @indentGuard spaceConsumer ord ref@ first consumes all white space -- (indentation) with @spaceConsumer@ parser, then it checks column -- position. Ordering between current indentation level and reference -- indentation level @ref@ should be @ord@, otherwise the parser fails. On -- success current column position is returned. -- -- When you want to parse block of indentation first run this parser with -- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@ — this will -- make sure you have some indentation. Use returned value to check -- indentation on every subsequent line according to syntax of your -- language. indentGuard :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> m Pos -- ^ Current column (indentation level) indentGuard sc ord ref = do sc actual <- indentLevel if compare actual ref == ord then return actual else incorrectIndent ord ref actual -- | Parse non-indented construction. This ensures that there is no -- indentation before actual data. Useful, for example, as a wrapper for -- top-level function definitions. -- -- @since 4.3.0 nonIndented :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> m a -- ^ How to parse actual data -> m a nonIndented sc p = indentGuard sc EQ (unsafePos 1) *> p -- | The data type represents available behaviors for parsing of indented -- tokens. This is used in 'indentBlock', which see. -- -- @since 4.3.0 data IndentOpt m a b = IndentNone a -- ^ Parse no indented tokens, just return the value | IndentMany (Maybe Pos) ([b] -> m a) (m b) -- ^ Parse many indented tokens (possibly zero), use given indentation -- level (if 'Nothing', use level of the first indented token); the -- second argument tells how to get final result, and third argument -- describes how to parse indented token | IndentSome (Maybe Pos) ([b] -> m a) (m b) -- ^ Just like 'IndentMany', but requires at least one indented token to -- be present -- | Parse a “reference” token and a number of other tokens that have -- greater (but the same) level of indentation than that of “reference” -- token. Reference token can influence parsing, see 'IndentOpt' for more -- information. -- -- Tokens /must not/ consume newlines after them. On the other hand, the -- first argument of this function /must/ consume newlines among other white -- space characters. -- -- @since 4.3.0 indentBlock :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume indentation (white space) -> m (IndentOpt m a b) -- ^ How to parse “reference” token -> m a indentBlock sc r = do sc ref <- indentLevel a <- r case a of IndentNone x -> return x IndentMany indent f p -> do mlvl <- optional . try $ C.eol *> indentGuard sc GT ref case mlvl of Nothing -> sc *> f [] Just lvl -> indentedItems ref (fromMaybe lvl indent) sc p >>= f IndentSome indent f p -> do lvl <- C.eol *> indentGuard sc GT ref indentedItems ref (fromMaybe lvl indent) sc p >>= f -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of public API. indentedItems :: MonadParsec e s m => Pos -- ^ Reference indentation level -> Pos -- ^ Level of the first indented item ('lookAhead'ed) -> m () -- ^ How to consume indentation (white space) -> m b -- ^ How to parse indented tokens -> m [b] indentedItems ref lvl sc p = go where go = (sc *> indentLevel) >>= re re pos | pos <= ref = return [] | pos == lvl = (:) <$> p <*> go | otherwise = do done <- isJust <$> optional eof if done then return [] else incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/ -- consume newlines in order to work properly. The second argument is a -- callback that receives custom space-consuming parser as argument. This -- parser should be used after separate components of line fold that can be -- put on different lines. -- -- An example should clarify the usage pattern: -- -- > sc = L.space (void spaceChar) empty empty -- > -- > myFold = L.lineFold sc $ \sc' -> do -- > L.symbol sc' "foo" -- > L.symbol sc' "bar" -- > L.symbol sc "baz" -- for the last symbol we use normal space consumer -- -- @since 5.0.0 lineFold :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> (m () -> m a) -- ^ Callback that uses provided space-consumer -> m a lineFold sc action = sc >> indentLevel >>= action . void . indentGuard sc GT ---------------------------------------------------------------------------- -- Character and string literals -- | The lexeme parser parses a single literal character without -- quotes. Purpose of this parser is to help with parsing of conventional -- escape sequences. It's your responsibility to take care of character -- literal syntax in your language (by surrounding it with single quotes or -- similar). -- -- The literal character is parsed according to the grammar rules defined in -- the Haskell report. -- -- Note that you can use this parser as a building block to parse various -- string literals: -- -- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"') charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint, -- and we do know that r will be non-empty if count' succeeds. ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar case listToMaybe (readLitChar r) of Just (c, r') -> count (length r - length r') C.anyChar >> return c Nothing -> unexpected (Tokens (x:|[])) ---------------------------------------------------------------------------- -- Numbers -- | Parse an integer without sign in decimal representation (according to -- format of integer literals described in Haskell report). -- -- If you need to parse signed integers, see 'signed' combinator. integer :: (MonadParsec e s m, Token s ~ Char) => m Integer integer = decimal "integer" -- | The same as 'integer', but 'integer' is 'label'ed with “integer” label, -- while this parser is labeled with “decimal integer”. decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer decimal = nump "" C.digitChar "decimal integer" -- | Parse an integer in hexadecimal representation. Representation of -- hexadecimal number is expected to be according to Haskell report except -- for the fact that this parser doesn't parse “0x” or “0X” prefix. It is -- responsibility of the programmer to parse correct prefix before parsing -- the number itself. -- -- For example you can make it conform to Haskell report like this: -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer hexadecimal = nump "0x" C.hexDigitChar "hexadecimal integer" -- | Parse an integer in octal representation. Representation of octal -- number is expected to be according to 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 e s m, Token s ~ Char) => m Integer octal = nump "0o" C.octDigitChar "octal integer" -- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then -- prepends @prefix@ to returned value and tries to interpret the result as -- an integer according to Haskell syntax. nump :: MonadParsec e s m => String -> m Char -> m Integer nump prefix baseDigit = read . (prefix ++) <$> some baseDigit -- | Parse floating point value as 'Scientific' number. 'Scientific' is -- great for parsing of arbitrary precision numbers coming from an untrusted -- source. See documentation in "Data.Scientific" for more information. -- Representation of floating point value is expected to be according to -- Haskell report. -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- -- @since 5.0.0 scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific scientific = label "floating point number" (read <$> f) where f = (++) <$> some C.digitChar <*> (fraction <|> fExp) -- | Parse floating point number without sign. This is a simple shortcut -- defined as: -- -- > float = toRealFloat <$> scientific float :: (MonadParsec e s m, Token s ~ Char) => m Double float = toRealFloat <$> scientific -- | This is a helper for 'float' parser. It parses fractional part of -- floating point number, that is, dot and everything after it. fraction :: (MonadParsec e s m, Token s ~ Char) => m String fraction = do void (C.char '.') d <- some C.digitChar e <- option "" fExp return ('.' : d ++ e) -- | This helper parses exponent of floating point numbers. fExp :: (MonadParsec e s m, Token s ~ Char) => m String fExp = do expChar <- C.char' 'e' signStr <- option "" (pure <$> choice (C.char <$> "+-")) d <- some C.digitChar return (expChar : signStr ++ d) -- | Parse a number: either integer or floating point. The parser can handle -- overlapping grammars graciously. Use functions like -- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and -- extract integer or real values. number :: (MonadParsec e s m, Token s ~ Char) => m Scientific number = label "number" (read <$> f) where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp) -- | @signed space p@ parser parses optional sign, then if there is a sign -- it will consume optional white space (using @space@ parser), then it runs -- parser @p@ which should return a number. Sign of the number is changed -- according to previously parsed sign. -- -- For example, to parse signed integer you can write: -- -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.integer -- > signedInteger = L.signed spaceConsumer integer signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a signed spc p = ($) <$> option id (lexeme spc sign) <*> p -- | Parse a sign and return either 'id' or 'negate' according to parsed -- sign. sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a) sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate) megaparsec-5.0.1/Text/Megaparsec/Perm.hs0000644000000000000000000001270012710173312016241 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Perm -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : non-portable -- -- This module implements permutation parsers. The algorithm is described -- in: /Parsing Permutation Phrases/, by Arthur Baars, Andres Loh and -- Doaitse Swierstra. Published as a functional pearl at the Haskell -- Workshop 2001. {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} module Text.Megaparsec.Perm ( PermParser , makePermParser , (<$$>) , (<$?>) , (<||>) , (<|?>) ) where import Text.Megaparsec.Combinator (choice) import Text.Megaparsec.Prim #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif infixl 1 <||>, <|?> infixl 2 <$$>, <$?> -- | The type @PermParser s m a@ denotes a permutation parser that, -- when converted by the 'makePermParser' function, produces instance of -- 'MonadParsec' @m@ that parses @s@ stream and returns a value of type @a@ -- on success. -- -- Normally, a permutation parser is first build with special operators like -- ('<||>') and than transformed into a normal parser using -- 'makePermParser'. data PermParser s m a = Perm (Maybe a) [Branch s m a] data Branch s m a = forall b. Branch (PermParser s m (b -> a)) (m b) -- | The parser @makePermParser perm@ parses a permutation of parser described -- by @perm@. For example, suppose we want to parse a permutation of: an -- optional string of @a@'s, the character @b@ and an optional @c@. This can -- be described by: -- -- > test = makePermParser $ -- > (,,) <$?> ("", some (char 'a')) -- > <||> char 'b' -- > <|?> ('_', char 'c') makePermParser :: MonadParsec e s m => PermParser s m a -- ^ Given permutation parser -> m a -- ^ Normal parser built from it makePermParser (Perm def xs) = choice (fmap branch xs ++ empty) where empty = case def of Nothing -> [] Just x -> [return x] branch (Branch perm p) = flip ($) <$> p <*> makePermParser perm -- | The expression @f \<$$> p@ creates a fresh permutation parser -- consisting of parser @p@. The the final result of the permutation parser -- is the function @f@ applied to the return value of @p@. The parser @p@ is -- not allowed to accept empty input — use the optional combinator ('<$?>') -- instead. -- -- If the function @f@ takes more than one parameter, the type variable @b@ -- is instantiated to a functional type which combines nicely with the adds -- parser @p@ to the ('<||>') combinator. This results in stylized code -- where a permutation parser starts with a combining function @f@ followed -- by the parsers. The function @f@ gets its parameters in the order in -- which the parsers are specified, but actual input can be in any order. (<$$>) :: MonadParsec e s m => (a -> b) -- ^ Function to use on result of parsing -> m a -- ^ Normal parser -> PermParser s m b -- ^ Permutation parser build from it f <$$> p = newperm f <||> p -- | The expression @f \<$?> (x, p)@ creates a fresh permutation parser -- consisting of parser @p@. The final result of the permutation parser is -- the function @f@ applied to the return value of @p@. The parser @p@ is -- optional — if it cannot be applied, the default value @x@ will be used -- instead. (<$?>) :: MonadParsec e s m => (a -> b) -- ^ Function to use on result of parsing -> (a, m a) -- ^ Default value and parser -> PermParser s m b -- ^ Permutation parser f <$?> xp = newperm f <|?> xp -- | The expression @perm \<||> p@ adds parser @p@ to the permutation -- parser @perm@. The parser @p@ is not allowed to accept empty input — use -- the optional combinator ('<|?>') instead. Returns a new permutation -- parser that includes @p@. (<||>) :: MonadParsec e s m => PermParser s m (a -> b) -- ^ Given permutation parser -> m a -- ^ Parser to add (should not accept empty input) -> PermParser s m b -- ^ Resulting parser (<||>) = add -- | The expression @perm \<||> (x, p)@ adds parser @p@ to the -- permutation parser @perm@. The parser @p@ is optional — if it cannot be -- applied, the default value @x@ will be used instead. Returns a new -- permutation parser that includes the optional parser @p@. (<|?>) :: MonadParsec e s m => PermParser s m (a -> b) -- ^ Given permutation parser -> (a, m a) -- ^ Default value and parser -> PermParser s m b -- ^ Resulting parser perm <|?> (x, p) = addopt perm x p newperm :: (a -> b) -> PermParser s m (a -> b) newperm f = Perm (Just f) [] add :: MonadParsec e s m => PermParser s m (a -> b) -> m a -> PermParser s m b add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs) where first = Branch perm p insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p' addopt :: MonadParsec e s m => PermParser s m (a -> b) -> a -> m a -> PermParser s m b addopt perm@(Perm mf fs) x p = Perm (fmap ($ x) mf) (first : fmap insert fs) where first = Branch perm p insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p' mapPerms :: MonadParsec e s m => (a -> b) -> PermParser s m a -> PermParser s m b mapPerms f (Perm x xs) = Perm (fmap f x) (fmap mapBranch xs) where mapBranch (Branch perm p) = Branch (mapPerms (f .) perm) p megaparsec-5.0.1/Text/Megaparsec/Pos.hs0000644000000000000000000001223212740657660016117 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Pos -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Textual source position. The position includes name of file, line number, -- and column number. List of such positions can be used to model stack of -- include files. {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} module Text.Megaparsec.Pos ( -- * Abstract position Pos , mkPos , unPos , unsafePos , InvalidPosException (..) -- * Source position , SourcePos (..) , initialPos , sourcePosPretty -- * Helpers implementing default behaviors , defaultUpdatePos , defaultTabWidth ) where import Control.DeepSeq import Control.Monad.Catch import Data.Data (Data) import Data.Semigroup import Data.Typeable (Typeable) import GHC.Generics import Unsafe.Coerce #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Word (Word) #endif ---------------------------------------------------------------------------- -- Abstract position -- | Positive integer that is used to represent line number, column number, -- and similar things like indentation level. 'Semigroup' instance can be -- used to safely and purely add 'Pos'es together. -- -- @since 5.0.0 newtype Pos = Pos Word deriving (Show, Eq, Ord, Data, Typeable, NFData) -- | Construction of 'Pos' from an instance of 'Integral'. The function -- throws 'InvalidPosException' when given non-positive argument. Note that -- the function is polymorphic with respect to 'MonadThrow' @m@, so you can -- get result inside of 'Maybe', for example. -- -- @since 5.0.0 mkPos :: (Integral a, MonadThrow m) => a -> m Pos mkPos x = if x < 1 then throwM InvalidPosException else (return . Pos . fromIntegral) x {-# INLINE mkPos #-} -- | Dangerous construction of 'Pos'. Use when you know for sure that -- argument is positive. -- -- @since 5.0.0 unsafePos :: Word -> Pos unsafePos x = if x < 1 then error "Text.Megaparsec.Pos.unsafePos" else Pos x {-# INLINE unsafePos #-} -- | Extract 'Word' from 'Pos'. -- -- @since 5.0.0 unPos :: Pos -> Word unPos = unsafeCoerce {-# INLINE unPos #-} instance Semigroup Pos where (Pos x) <> (Pos y) = Pos (x + y) {-# INLINE (<>) #-} instance Read Pos where readsPrec d = readParen (d > 10) $ \r1 -> do ("Pos", r2) <- lex r1 (x, r3) <- readsPrec 11 r2 (,r3) <$> mkPos (x :: Integer) -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number. -- -- @since 5.0.0 data InvalidPosException = InvalidPosException deriving (Eq, Show, Data, Typeable, Generic) instance Exception InvalidPosException instance NFData InvalidPosException ---------------------------------------------------------------------------- -- Source position -- | The data type @SourcePos@ represents source positions. It contains the -- name of the source file, a line number, and a column number. Source line -- and column positions change intensively during parsing, so we need to -- make them strict to avoid memory leaks. data SourcePos = SourcePos { sourceName :: FilePath -- ^ Name of source file , sourceLine :: !Pos -- ^ Line number , sourceColumn :: !Pos -- ^ Column number } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) instance NFData SourcePos -- | Construct initial position (line 1, column 1) given name of source -- file. initialPos :: String -> SourcePos initialPos n = SourcePos n u u where u = unsafePos 1 {-# INLINE initialPos #-} -- | Pretty-print a 'SourcePos'. -- -- @since 5.0.0 sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c) | null n = showLC | otherwise = n ++ ":" ++ showLC where showLC = show (unPos l) ++ ":" ++ show (unPos c) ---------------------------------------------------------------------------- -- Helpers implementing default behaviors -- | Update a source position given a character. The first argument -- specifies tab width. If the character is a newline (\'\\n\') the line -- number is incremented by 1. If the character is a tab (\'\\t\') the -- column number is incremented to the nearest tab position. In all other -- cases, the column is incremented by 1. -- -- @since 5.0.0 defaultUpdatePos :: Pos -- ^ Tab width -> SourcePos -- ^ Current position -> Char -- ^ Current token -> (SourcePos, SourcePos) -- ^ Actual position and incremented position defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos) where u = unsafePos 1 w = unPos width c' = unPos c npos = case ch of '\n' -> SourcePos n (l <> u) u '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w)) _ -> SourcePos n l (c <> u) -- | Value of tab width used by default. Always prefer this constant when -- you want to refer to default tab width because actual value /may/ change -- in future. Current value is @8@. defaultTabWidth :: Pos defaultTabWidth = unsafePos 8 megaparsec-5.0.1/Text/Megaparsec/Prim.hs0000644000000000000000000011776012740660522016270 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Prim -- Copyright : © 2015–2016 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : non-portable -- -- The primitive parser combinators. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} module Text.Megaparsec.Prim ( -- * Data types State (..) , Stream (..) , Parsec , ParsecT -- * Primitive combinators , MonadParsec (..) , () , unexpected -- * Parser state combinators , getInput , setInput , getPosition , setPosition , pushPosition , popPosition , getTabWidth , setTabWidth , setParserState -- * Running parser , runParser , runParser' , runParserT , runParserT' , parse , parseMaybe , parseTest ) where import Control.DeepSeq import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.Identity import Control.Monad.Reader.Class import Control.Monad.State.Class hiding (state) import Control.Monad.Trans import Control.Monad.Trans.Identity import Data.Data (Data) import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid hiding ((<>)) import Data.Proxy import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Generics import Prelude hiding (all) import qualified Control.Applicative as A import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Trans.Reader as L import qualified Control.Monad.Trans.State.Lazy as L import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Lazy as L import qualified Control.Monad.Trans.Writer.Strict as S import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Text.Megaparsec.Error import Text.Megaparsec.Pos #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), pure) #endif ---------------------------------------------------------------------------- -- Data types -- | This is Megaparsec's state, it's parametrized over stream type @s@. data State s = State { stateInput :: s , statePos :: NonEmpty SourcePos , stateTabWidth :: Pos } deriving (Show, Eq, Data, Typeable, Generic) instance NFData s => NFData (State s) -- | All information available after parsing. This includes consumption of -- input, success (with returned value) or failure (with parse error), and -- parser state at the end of parsing. -- -- See also: 'Consumption', 'Result'. data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) -- | This data structure represents an aspect of result of parser's -- work. -- -- See also: 'Result', 'Reply'. data Consumption = Consumed -- ^ Some part of input stream was consumed | Virgin -- ^ No input was consumed -- | This data structure represents an aspect of result of parser's -- work. -- -- See also: 'Consumption', 'Reply'. data Result t e a = OK a -- ^ Parser succeeded | Error (ParseError t e) -- ^ Parser failed -- | 'Hints' represent collection of strings to be included into -- 'ParserError' as “expected” message items when a parser fails without -- consuming input right after successful parser that produced the hints. -- -- For example, without hints you could get: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2: -- unexpected 'a' -- expecting end of input -- -- We're getting better error messages with help of hints: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid) -- | Convert 'ParseError' record into 'Hints'. toHints :: ParseError t e -> Hints t toHints err = Hints hints where hints = if E.null msgs then [] else [msgs] msgs = errorExpected err {-# INLINE toHints #-} -- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. -- -- Note that if resulting continuation gets 'ParseError' that has only -- custom data in it (no “unexpected” or “expected” items), hints are -- ignored. withHints :: Ord (Token s) => Hints (Token s) -- ^ Hints to use -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence -> ParseError (Token s) e -- ^ First argument of resulting continuation -> State s -- ^ Second argument of resulting continuation -> m b withHints (Hints ps') c e@(ParseError pos us ps xs) = if E.null us && E.null ps && not (E.null xs) then c e else c (ParseError pos us (E.unions (ps : ps')) xs) {-# INLINE withHints #-} -- | @accHints hs c@ results in “OK” continuation that will add given hints -- @hs@ to third argument of original continuation @c@. accHints :: Hints t -- ^ 'Hints' to add -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter -> a -- ^ First argument of resulting continuation -> State s -- ^ Second argument of resulting continuation -> Hints t -- ^ Third argument of resulting continuation -> m b accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} -- | Replace most recent group of hints (if any) with given 'ErrorItem' (or -- delete it if 'Nothing' is given). This is used in 'label' primitive. refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t refreshLastHint (Hints []) _ = Hints [] refreshLastHint (Hints (_:xs)) Nothing = Hints xs refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) {-# INLINE refreshLastHint #-} -- | An instance of @Stream s@ has stream type @s@. Token type is determined -- by the stream and can be found via 'Token' type function. class Ord (Token s) => Stream s where -- | Type of token in stream. -- -- @since 5.0.0 type Token s :: * -- | Get next token from the stream. If the stream is empty, return -- 'Nothing'. uncons :: s -> Maybe (Token s, s) -- | Update position in stream given tab width, current position, and -- current token. The result is a tuple where the first element will be -- used to report parse errors for current token, while the second element -- is the incremented position that will be stored in parser's state. -- -- When you work with streams where elements do not contain information -- about their position in input, result is usually consists of the third -- argument unchanged and incremented position calculated with respect to -- current token. This is how default instances of 'Stream' work (they use -- 'defaultUpdatePos', which may be a good starting point for your own -- position-advancing function). -- -- When you wish to deal with stream of tokens where every token “knows” -- its start and end position in input (for example, you have produced the -- stream with Happy\/Alex), then the best strategy is to use the start -- position as actual element position and provide the end position of the -- token as incremented one. -- -- @since 5.0.0 updatePos :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective) -> Pos -- ^ Tab width -> SourcePos -- ^ Current position -> Token s -- ^ Current token -> (SourcePos, SourcePos) -- ^ Actual position and incremented position instance Stream String where type Token String = Char uncons [] = Nothing uncons (t:ts) = Just (t, ts) {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream B.ByteString where type Token B.ByteString = Char uncons = B.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream BL.ByteString where type Token BL.ByteString = Char uncons = BL.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream T.Text where type Token T.Text = Char uncons = T.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream TL.Text where type Token TL.Text = Char uncons = TL.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} -- 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 -- current value of tab width. -- -- * “Consumed-OK” continuation (cok). This is 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. This continuation takes 'ParseError' and state information -- at the time error occurred. -- -- * “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 takes -- 'ParseError' record and state information. -- -- 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 e s = ParsecT e s Identity -- | @ParsecT e s m a@ is a parser with custom data component of error @e@, -- stream type @s@, underlying monad @m@ and return type @a@. newtype ParsecT e s m a = ParsecT { unParser :: forall b. State s -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK -> (ParseError (Token s) e -> State s -> m b) -- consumed-error -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK -> (ParseError (Token s) e -> State s -> m b) -- empty-error -> m b } instance Functor (ParsecT e s m) where fmap = pMap pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b pMap f p = ParsecT $ \s cok cerr eok eerr -> unParser p s (cok . f) cerr (eok . f) eerr {-# INLINE pMap #-} instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where pure = pPure (<*>) = pAp p1 *> p2 = p1 `pBind` const p2 p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } pAp :: Stream s => ParsecT e s m (a -> b) -> ParsecT e s m a -> ParsecT e s m b pAp m k = ParsecT $ \s cok cerr eok eerr -> let mcok x s' hs = unParser k s' (cok . x) cerr (accHints hs (cok . x)) (withHints hs cerr) meok x s' hs = unParser k s' (cok . x) cerr (accHints hs (eok . x)) (withHints hs eerr) in unParser m s mcok cerr meok eerr {-# INLINE pAp #-} instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where empty = mzero (<|>) = mplus many p = reverse <$> manyAcc p manyAcc :: ParsecT e s m a -> ParsecT e 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 may consume no input." instance (ErrorComponent e, Stream s) => Monad (ParsecT e s m) where return = pure (>>=) = pBind fail = Fail.fail pPure :: a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} pBind :: Stream s => ParsecT e s m a -> (a -> ParsecT e s m b) -> ParsecT e s m b pBind m k = ParsecT $ \s cok cerr eok eerr -> let mcok x s' hs = unParser (k x) s' cok cerr (accHints hs cok) (withHints hs cerr) meok x s' hs = unParser (k x) s' cok cerr (accHints hs eok) (withHints hs eerr) in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} instance (ErrorComponent e, Stream s) => Fail.MonadFail (ParsecT e s m) where fail = pFail pFail :: ErrorComponent e => String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ pos _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty d) s where d = E.singleton (representFail msg) {-# INLINE pFail #-} -- | Low-level creation of the 'ParsecT' type. mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a mkPT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of OK x -> cok x s' mempty Error e -> cerr e s' Virgin -> case result of OK x -> eok x s' mempty Error e -> eerr e s' instance (ErrorComponent e, Stream s, MonadIO m) => MonadIO (ParsecT e s m) where liftIO = lift . liftIO instance (ErrorComponent e, Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where ask = lift ask local f p = mkPT $ \s -> local f (runParsecT p s) instance (ErrorComponent e, Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put instance (ErrorComponent e, Stream s, MonadCont m) => MonadCont (ParsecT e s m) where callCC f = mkPT $ \s -> callCC $ \c -> runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s where pack s a = Reply s Virgin (OK a) instance (ErrorComponent e, Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError p `catchError` h = mkPT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s instance (ErrorComponent e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus pZero :: ParsecT e s m a pZero = ParsecT $ \s@(State _ pos _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty E.empty) s {-# INLINE pZero #-} pPlus :: (ErrorComponent e, Stream s) => ParsecT e s m a -> ParsecT e s m a -> ParsecT e s m a pPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err ms = let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') neok x s' hs = eok x s' (toHints err <> hs) neerr err' s' = eerr (err' <> err) (longestMatch ms s') in unParser n s cok ncerr neok neerr in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} -- | From two states, return the one with greater textual position. If the -- positions are equal, prefer the latter state. longestMatch :: State s -> State s -> State s longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) = case pos1 `compare` pos2 of LT -> s2 EQ -> s2 GT -> s1 {-# INLINE longestMatch #-} instance MonadTrans (ParsecT e s) where lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty ---------------------------------------------------------------------------- -- Primitive combinators -- | Type class describing parsers independent of input type. class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m) => MonadParsec e s m | m -> e s where -- | The most general way to stop parsing and report 'ParseError'. -- -- 'unexpected' is defined in terms of this function: -- -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty -- -- @since 4.2.0 failure :: Set (ErrorItem (Token s)) -- ^ Unexpected items -> Set (ErrorItem (Token s)) -- ^ Expected items -> Set e -- ^ Custom data -> m a -- | The parser @label name p@ behaves as parser @p@, but whenever the -- parser @p@ fails /without consuming any input/, it replaces names of -- “expected” tokens with the name @name@. label :: String -> m a -> m a -- | @hidden p@ behaves just like parser @p@, but it doesn't show any -- “expected” tokens in error message when @p@ fails. hidden :: m a -> m a hidden = label "" -- | The parser @try p@ behaves like parser @p@, except that it -- 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 is supposed to parse word “let” or -- “lexical”: -- -- >>> parseTest (string "let" <|> string "lexical") "lexical" -- 1: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" -- 1:1: -- unexpected "le" -- expecting "let" or "lexical" -- -- Please note that as of Megaparsec 4.4.0, 'string' backtracks -- automatically (see 'tokens'), so it does not need 'try'. However, the -- examples above demonstrate the idea behind 'try' so well that it was -- decided to keep them. 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 () -- | @withRecovery r p@ allows continue parsing even if parser @p@ fails. -- In this case @r@ is called with actual 'ParseError' as its argument. -- Typical usage is to return value signifying failure to parse this -- particular object and to consume some part of input up to start of next -- object. -- -- Note that if @r@ fails, original error message is reported as if -- without 'withRecovery'. In no way recovering parser @r@ can influence -- error messages. -- -- @since 4.4.0 withRecovery :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure -> m a -- ^ Original parser -> m a -- ^ Parser that can recover from failures -- | This parser only succeeds at the end of the input. eof :: m () -- | The parser @token test mrep@ accepts a token @t@ with result @x@ when -- the function @test t@ returns @'Right' x@. @mrep@ may provide -- representation of the token to report in error messages when input -- stream in empty. -- -- This is the most primitive combinator for accepting tokens. For -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: -- -- > satisfy f = token testChar Nothing -- > where -- > testChar x = -- > if f x -- > then Right x -- > else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty) token :: (Token s -> Either ( Set (ErrorItem (Token s)) , Set (ErrorItem (Token s)) , Set e ) a) -- ^ Matching function for the token to parse, it allows to construct -- arbitrary error message on failure as well; sets in three-tuple -- are: unexpected items, expected items, and custom data pieces -> Maybe (Token s) -- ^ Token to report when input stream is empty -> m a -- | The parser @tokens test@ parses list of tokens and returns it. -- Supplied predicate @test@ is used to check equality of given and parsed -- tokens. -- -- This can be used for example to write 'Text.Megaparsec.Char.string': -- -- > string = tokens (==) -- -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking -- primitive, which means that if it fails, it never consumes any -- input. This is done to make its consumption model match how error -- messages for this primitive are reported (which becomes an important -- thing as user gets more control with primitives like 'withRecovery'): -- -- >>> parseTest (string "abc") "abd" -- 1:1: -- unexpected "abd" -- expecting "abc" -- -- This means, in particular, that it's no longer necessary to use 'try' -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect -- performance in any way. tokens :: (Token s -> Token s -> Bool) -- ^ Predicate to check equality of tokens -> [Token s] -- ^ List of tokens to parse -> m [Token s] -- | 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 (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where failure = pFailure label = pLabel try = pTry lookAhead = pLookAhead notFollowedBy = pNotFollowedBy withRecovery = pWithRecovery eof = pEof token = pToken tokens = pTokens getParserState = pGetParserState updateParserState = pUpdateParserState pFailure :: Set (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> Set e -> ParsecT e s m a pFailure us ps xs = ParsecT $ \s@(State _ pos _) _ _ _ eerr -> eerr (ParseError pos us ps xs) s {-# INLINE pFailure #-} pLabel :: String -> ParsecT e s m a -> ParsecT e s m a pLabel l p = ParsecT $ \s cok cerr eok eerr -> let el = Label <$> NE.nonEmpty l cl = Label . (NE.fromList "rest of " <>) <$> NE.nonEmpty l cok' x s' hs = cok x s' (refreshLastHint hs cl) eok' x s' hs = eok x s' (refreshLastHint hs el) eerr' err = eerr err { errorExpected = maybe E.empty E.singleton el } in unParser p s cok' cerr eok' eerr' {-# INLINE pLabel #-} pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr -> unParser p s cok eerr eok eerr {-# INLINE pTry #-} pLookAhead :: ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr -> let eok' a _ _ = eok a s mempty in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (uncons input) unexpect u = ParseError pos (E.singleton u) E.empty E.empty cok' _ _ _ = eerr (unexpect what) s cerr' _ _ = eok () s mempty eok' _ _ _ = eerr (unexpect what) s eerr' _ _ = eok () s mempty in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-} pWithRecovery :: (ParseError (Token s) e -> ParsecT e s m a) -> ParsecT e s m a -> ParsecT e s m a pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> let mcerr err ms = let rcok x s' _ = cok x s' mempty rcerr _ _ = cerr err ms reok x s' _ = eok x s' (toHints err) reerr _ _ = cerr err ms in unParser (r err) ms rcok rcerr reok reerr meerr err ms = let rcok x s' _ = cok x s' (toHints err) rcerr _ _ = eerr err ms reok x s' _ = eok x s' (toHints err) reerr _ _ = eerr err ms in unParser (r err) ms rcok rcerr reok reerr in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} pEof :: forall e s m. Stream s => ParsecT e s m () pEof = ParsecT $ \s@(State input (pos:|z) w) _ _ eok eerr -> case uncons input of Nothing -> eok () s mempty Just (x,_) -> let !apos = fst (updatePos (Proxy :: Proxy s) w pos x) in eerr ParseError { errorPos = apos:|z , errorUnexpected = (E.singleton . Tokens . nes) x , errorExpected = E.singleton EndOfInput , errorCustom = E.empty } (State input (apos:|z) w) {-# INLINE pEof #-} pToken :: forall e s m a. Stream s => (Token s -> Either ( Set (ErrorItem (Token s)) , Set (ErrorItem (Token s)) , Set e ) a) -> Maybe (Token s) -> ParsecT e s m a pToken test mtoken = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr -> case uncons input of Nothing -> eerr ParseError { errorPos = pos:|z , errorUnexpected = E.singleton EndOfInput , errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtoken , errorCustom = E.empty } s Just (c,cs) -> let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c in case test c of Left (us, ps, xs) -> apos `seq` eerr (ParseError (apos:|z) us ps xs) (State input (apos:|z) w) Right x -> let newstate = State cs (npos:|z) w in npos `seq` cok x newstate mempty {-# INLINE pToken #-} pTokens :: forall e s m. Stream s => (Token s -> Token s -> Bool) -> [Token s] -> ParsecT e s m [Token s] pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty pTokens test tts = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr -> let updatePos' = updatePos (Proxy :: Proxy s) w toTokens = Tokens . NE.fromList . reverse unexpect pos' u = ParseError { errorPos = pos' , errorUnexpected = E.singleton u , errorExpected = (E.singleton . Tokens . NE.fromList) tts , errorCustom = E.empty } go _ [] is rs = let ris = reverse is !npos = foldl' (\p t -> snd (updatePos' p t)) pos ris in cok ris (State rs (npos:|z) w) mempty go apos (t:ts) is rs = case uncons rs of Nothing -> apos `seq` eerr (unexpect (apos:|z) (toTokens is)) (State input (apos:|z) w) Just (x,xs) -> if test t x then go apos ts (x:is) xs else apos `seq` eerr (unexpect (apos:|z) . toTokens $ x:is) (State input (apos:|z) w) in case uncons input of Nothing -> eerr (unexpect (pos:|z) EndOfInput) s Just (x,xs) -> let t:ts = tts apos = fst (updatePos' pos x) in if test t x then go apos ts [x] xs else apos `seq` eerr (unexpect (apos:|z) $ Tokens (nes x)) (State input (apos:|z) w) {-# INLINE pTokens #-} pGetParserState :: ParsecT e s m (State s) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} pUpdateParserState :: (State s -> State s) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} -- | A synonym for 'label' in form of an operator. infix 0 () :: MonadParsec e s m => m a -> String -> m a () = flip label -- | The parser @unexpected item@ always fails with an error message telling -- about unexpected item @item@ without consuming any input. unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a unexpected item = failure (E.singleton item) E.empty E.empty {-# INLINE unexpected #-} -- | Make a singleton non-empty list from a value. nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} ---------------------------------------------------------------------------- -- Parser state combinators -- | Return the current input. getInput :: MonadParsec e s m => m s getInput = stateInput <$> getParserState -- | @setInput input@ continues parsing with @input@. The 'getInput' and -- 'setInput' functions can for example be used to deal with include files. setInput :: MonadParsec e s m => s -> m () setInput s = updateParserState (\(State _ pos w) -> State s pos w) -- | Return the current source position. -- -- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'. getPosition :: MonadParsec e s m => m SourcePos getPosition = NE.head . statePos <$> getParserState -- | @setPosition pos@ sets the current source position to @pos@. -- -- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. setPosition :: MonadParsec e s m => SourcePos -> m () setPosition pos = updateParserState $ \(State s (_:|z) w) -> State s (pos:|z) w -- | Push given position into stack of positions and continue parsing -- working with this position. Useful for working with include files and the -- like. -- -- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'. -- -- @since 5.0.0 pushPosition :: MonadParsec e s m => SourcePos -> m () pushPosition pos = updateParserState $ \(State s z w) -> State s (NE.cons pos z) w -- | Pop a position from stack of positions unless it only contains one -- element (in that case stack of positions remains the same). This is how -- to return to previous source file after 'pushPosition'. -- -- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'. -- -- @since 5.0.0 popPosition :: MonadParsec e s m => m () popPosition = updateParserState $ \(State s z w) -> case snd (NE.uncons z) of Nothing -> State s z w Just z' -> State s z' w -- | Return tab width. Default tab width is equal to 'defaultTabWidth'. You -- can set different tab width with help of 'setTabWidth'. getTabWidth :: MonadParsec e s m => m Pos getTabWidth = stateTabWidth <$> getParserState -- | Set tab width. If argument of the function is not positive number, -- 'defaultTabWidth' will be used. setTabWidth :: MonadParsec e s m => Pos -> m () setTabWidth w = updateParserState (\(State s pos _) -> State s pos w) -- | @setParserState st@ set the full parser state to @st@. setParserState :: MonadParsec e s m => State s -> m () setParserState st = updateParserState (const st) ---------------------------------------------------------------------------- -- Running a parser -- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT' -- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a -- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn -- 'ParseError' into the string representation of the error message. See -- "Text.Megaparsec.Error" if you need to do more advanced error analysis. -- -- > main = case (parse numbers "" "11,2,43") of -- > Left err -> putStr (parseErrorPretty err) -- > Right xs -> print (sum xs) -- > -- > numbers = integer `sepBy` char ',' parse :: Parsec e s a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> Either (ParseError (Token s) e) a parse = runParser -- | @parseMaybe p input@ runs 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 :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s = case parse (p <* eof) "" s of Left _ -> Nothing Right x -> Just x -- | The expression @parseTest p input@ applies a parser @p@ against input -- @input@ and prints the result to stdout. Useful for testing. parseTest :: ( ShowErrorComponent e , Ord (Token s) , ShowToken (Token s) , Show a ) => Parsec e s a -- ^ Parser to run -> s -- ^ Input for parser -> IO () parseTest p input = case parse p "" input of Left e -> putStr (parseErrorPretty e) Right x -> print x -- | @runParser p file input@ runs parser @p@ on the input 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 :: Parsec e s a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> Either (ParseError (Token s) e) a runParser p name s = snd $ runParser' p (initialState name s) -- | The function is similar to 'runParser' with the difference that it -- accepts and returns parser state. This allows to specify arbitrary -- textual position at the beginning of parsing, for example. This is the -- most general way to run a parser over the 'Identity' monad. -- -- @since 4.2.0 runParser' :: Parsec e s a -- ^ Parser to run -> State s -- ^ Initial state -> (State s, Either (ParseError (Token s) e) a) runParser' p = runIdentity . runParserT' p -- | @runParserT p file input@ runs parser @p@ on the input list of tokens -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns a computation in the -- underlying monad @m@ that returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). runParserT :: Monad m => ParsecT e s m a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> m (Either (ParseError (Token s) e) a) runParserT p name s = snd `liftM` runParserT' p (initialState name s) -- | This function is similar to 'runParserT', but like 'runParser'' it -- accepts and returns parser state. This is thus the most general way to -- run a parser. -- -- @since 4.2.0 runParserT' :: Monad m => ParsecT e s m a -- ^ Parser to run -> State s -- ^ Initial state -> m (State s, Either (ParseError (Token s) e) a) runParserT' p s = do (Reply s' _ result) <- runParsecT p s case result of OK x -> return (s', Right x) Error e -> return (s', Left e) -- | Given name of source file and input construct initial state for parser. initialState :: String -> s -> State s initialState name s = State s (initialPos name :| []) defaultTabWidth -- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' -- are built upon this. runParsecT :: Monad m => ParsecT e s m a -- ^ Parser to run -> State s -- ^ Initial state -> m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr where cok a s' _ = return $ Reply s' Consumed (OK a) cerr err s' = return $ Reply s' Consumed (Error err) eok a s' _ = return $ Reply s' Virgin (OK a) eerr err s' = return $ Reply s' Virgin (Error err) ---------------------------------------------------------------------------- -- Instances of 'MonadParsec' instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where failure us ps xs = lift (failure us ps xs) label n (L.StateT m) = L.StateT $ label n . m try (L.StateT m) = L.StateT $ try . m lookAhead (L.StateT m) = L.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (L.StateT m) = L.StateT $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) withRecovery r (L.StateT m) = L.StateT $ \s -> withRecovery (\e -> L.runStateT (r e) s) (m s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where failure us ps xs = lift (failure us ps xs) label n (S.StateT m) = S.StateT $ label n . m try (S.StateT m) = S.StateT $ try . m lookAhead (S.StateT m) = S.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (S.StateT m) = S.StateT $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) withRecovery r (S.StateT m) = S.StateT $ \s -> withRecovery (\e -> S.runStateT (r e) s) (m s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (L.ReaderT st m) where failure us ps xs = lift (failure us ps xs) label n (L.ReaderT m) = L.ReaderT $ label n . m try (L.ReaderT m) = L.ReaderT $ try . m lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> withRecovery (\e -> L.runReaderT (r e) s) (m s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where failure us ps xs = lift (failure us ps xs) label n (L.WriterT m) = L.WriterT $ label n m try (L.WriterT m) = L.WriterT $ try m lookAhead (L.WriterT m) = L.WriterT $ (,mempty) . fst <$> lookAhead m notFollowedBy (L.WriterT m) = L.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) withRecovery r (L.WriterT m) = L.WriterT $ withRecovery (L.runWriterT . r) m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where failure us ps xs = lift (failure us ps xs) label n (S.WriterT m) = S.WriterT $ label n m try (S.WriterT m) = S.WriterT $ try m lookAhead (S.WriterT m) = S.WriterT $ (,mempty) . fst <$> lookAhead m notFollowedBy (S.WriterT m) = S.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) withRecovery r (S.WriterT m) = S.WriterT $ withRecovery (S.runWriterT . r) m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (IdentityT m) where failure us ps xs = lift (failure us ps xs) label n (IdentityT m) = IdentityT $ label n m try = IdentityT . try . runIdentityT lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m withRecovery r (IdentityT m) = IdentityT $ withRecovery (runIdentityT . r) m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift $ tokens e ts getParserState = lift getParserState updateParserState f = lift $ updateParserState f megaparsec-5.0.1/Text/Megaparsec/String.hs0000644000000000000000000000124312710173312016604 0ustar0000000000000000-- | -- Module : Text.Megaparsec.String -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Convenience definitions for working with 'String' as input stream. module Text.Megaparsec.String (Parser) where import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim -- | Modules corresponding to various types of streams define 'Parser' -- accordingly, so user can use it to easily change type of input stream by -- importing different “type modules”. This one is for strings. type Parser = Parsec Dec String megaparsec-5.0.1/Text/Megaparsec/Text.hs0000644000000000000000000000124712710173312016266 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Text -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Convenience definitions for working with strict 'Text'. module Text.Megaparsec.Text (Parser) where import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim import Data.Text -- | Modules corresponding to various types of streams define 'Parser' -- accordingly, so user can use it to easily change type of input stream by -- importing different “type modules”. This one is for strict text. type Parser = Parsec Dec Text megaparsec-5.0.1/Text/Megaparsec/Text/Lazy.hs0000644000000000000000000000126212710173312017202 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Text.Lazy -- Copyright : © 2015–2016 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Convenience definitions for working with lazy 'Text'. module Text.Megaparsec.Text.Lazy (Parser) where import Data.Text.Lazy import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim -- | Modules corresponding to various types of streams define 'Parser' -- accordingly, so user can use it to easily change type of input stream by -- importing different “type modules”. This one is for lazy text. type Parser = Parsec Dec Text megaparsec-5.0.1/tests/Main.hs0000644000000000000000000000340312656041032014373 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec, main module. -- -- Copyright © 2015–2016 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 ] megaparsec-5.0.1/tests/Char.hs0000644000000000000000000002137612710173312014373 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's character parsers. -- -- Copyright © 2015–2016 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 #-} {-# OPTIONS -fno-warn-orphans #-} module Char (tests) where import Data.Char import Data.List (findIndex, isPrefixOf) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Error import Util #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif 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'_0 , testProperty "string' (case)" prop_string'_1 ] instance Arbitrary GeneralCategory where arbitrary = elements [minBound..maxBound] prop_newline :: String -> Property prop_newline = checkChar newline (== '\n') (tkn '\n') prop_crlf :: String -> Property prop_crlf = checkString crlf "\r\n" (==) 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 [ueof, elabel "end of line"] | h == '\n' = posErr 1 s [utok (s !! 1), eeof] | h /= '\r' = posErr 0 s [utok h, elabel "end of line"] | "\r\n" `isPrefixOf` s = posErr 2 s [utok (s !! 2), eeof] | otherwise = posErr 0 s [ utoks (take 2 s) , utok '\r' , elabel "end of line" ] prop_tab :: String -> Property prop_tab = checkChar tab (== '\t') (tkn '\t') 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 [ utok ch , utok ch , elabel "white space" , eeof ] Nothing -> Right () prop_controlChar :: String -> Property prop_controlChar = checkChar controlChar isControl (lbl "control character") prop_spaceChar :: String -> Property prop_spaceChar = checkChar spaceChar isSpace (lbl "white space") prop_upperChar :: String -> Property prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter") prop_lowerChar :: String -> Property prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter") prop_letterChar :: String -> Property prop_letterChar = checkChar letterChar isAlpha (lbl "letter") prop_alphaNumChar :: String -> Property prop_alphaNumChar = checkChar alphaNumChar isAlphaNum (lbl "alphanumeric character") prop_printChar :: String -> Property prop_printChar = checkChar printChar isPrint (lbl "printable character") prop_digitChar :: String -> Property prop_digitChar = checkChar digitChar isDigit (lbl "digit") prop_octDigitChar :: String -> Property prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit") prop_hexDigitChar :: String -> Property prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit") prop_markChar :: String -> Property prop_markChar = checkChar markChar isMark (lbl "mark character") prop_numberChar :: String -> Property prop_numberChar = checkChar numberChar isNumber (lbl "numeric character") prop_punctuationChar :: String -> Property prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation") prop_symbolChar :: String -> Property prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol") prop_separatorChar :: String -> Property prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator") prop_asciiChar :: String -> Property prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character") prop_latin1Char :: String -> Property prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character") prop_charCategory :: GeneralCategory -> String -> Property prop_charCategory cat = checkChar (charCategory cat) p (lbl $ categoryName cat) where p c = generalCategory c == cat prop_char :: Char -> String -> Property prop_char c = checkChar (char c) (== c) (tkn 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 $ ueof : (etok <$> l) | length s == 1 && (h `elemi` l) = Right h | h `notElemi` l = posErr 0 s $ utok h : (etok <$> l) | otherwise = posErr 1 s [utok (s !! 1), eeof] prop_anyChar :: String -> Property prop_anyChar = checkChar anyChar (const True) (lbl "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 (==) prop_string'_0 :: String -> String -> Property prop_string'_0 a = checkString (string' a) a casei -- | Randomly change the case in the given string. fuzzyCase :: String -> Gen String fuzzyCase s = zipWith f s <$> vector (length s) where f k True = if isLower k then toUpper k else toLower k f k False = k prop_string'_1 :: String -> Property prop_string'_1 a = forAll (fuzzyCase a) $ \s -> checkString (string' a) a casei s -- | 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 tkn :: Char -> Maybe (ErrorItem Char) tkn = Just . Tokens . (:|[]) lbl :: String -> Maybe (ErrorItem Char) lbl = Just . Label . NE.fromList megaparsec-5.0.1/tests/Combinator.hs0000644000000000000000000002302412710173312015603 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's generic parser combinators. -- -- Copyright © 2015–2016 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.Char (isLetter, isDigit) 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 eitherP" prop_eitherP , 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 sepEndBy" prop_sepEndBy , testProperty "combinator sepEndBy1" prop_sepEndBy1 , 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 $ etoks post : etok c : [if length post == b then ueof else utoks [post !! b]] | 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 $ utok s' : (etok <$> 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 [utok 'x', eeof] | m <= x && x <= n = Right s | x < m = posErr x s [ueof, etok 'x'] | otherwise = posErr n s [utok 'x', eeof] s = replicate x 'x' prop_eitherP :: Char -> Property prop_eitherP ch = checkParser p r s where p = eitherP letterChar digitChar r | isLetter ch = Right (Left ch) | isDigit ch = Right (Right ch) | otherwise = posErr 0 s [utok ch, elabel "letter", elabel "digit"] s = pure ch 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 [ueof, etok '-'] | c == 'a' = posErr (g n) s [utok 'a', etok '-'] | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a', eeof] | c /= '-' = posErr (g n) s $ utok c : (if n > 0 then etok '-' else eeof) : [etok '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 [ueof, etok '-'] | c == 'a' = posErr (g n) s [utok 'a', etok '-'] | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a'] | c /= '-' = posErr (g n) s $ utok c : [etok '-' | n > 0] ++ [etok '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 [ueof, etok 'c', elabel "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 [ueof, elabel "letter"] | c == 0 = posErr (a + b) s [ueof, etok 'c', elabel "letter"] | s == "c" = posErr 1 s [ueof, etok 'c', elabel "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 [utok c, etok 'a', eeof] | c == '-' = posErr (length s) s [ueof, etok 'a'] | otherwise = posErr (g n) s [utok c, etok '-', eeof] 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 [ueof, etok 'a'] | c == 'a' && n == 0 = Right "a" | n == 0 = posErr 0 s [utok c, etok 'a'] | c == '-' = posErr (length s) s [ueof, etok 'a'] | otherwise = posErr (g n) s [utok c, etok '-', eeof] s = intersperse '-' (replicate n 'a') ++ maybeToList c' prop_sepEndBy :: NonNegative Int -> Maybe Char -> Property prop_sepEndBy n' c' = checkParser p r s where n = getNonNegative n' c = fromJust c' p = sepEndBy (char 'a') (char '-') a = Right $ replicate n 'a' r | isNothing c' = a | c == 'a' && n == 0 = Right "a" | n == 0 = posErr 0 s [utok c, etok 'a', eeof] | c == '-' = a | otherwise = posErr (g n) s [utok c, etok '-', eeof] s = intersperse '-' (replicate n 'a') ++ maybeToList c' prop_sepEndBy1 :: NonNegative Int -> Maybe Char -> Property prop_sepEndBy1 n' c' = checkParser p r s where n = getNonNegative n' c = fromJust c' p = sepEndBy1 (char 'a') (char '-') a = Right $ replicate n 'a' r | isNothing c' && n >= 1 = a | isNothing c' = posErr 0 s [ueof, etok 'a'] | c == 'a' && n == 0 = Right "a" | n == 0 = posErr 0 s [utok c, etok 'a'] | c == '-' = a | otherwise = posErr (g n) s [utok c, etok '-', eeof] 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 megaparsec-5.0.1/tests/Error.hs0000644000000000000000000001307212711105612014600 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's parse errors. -- -- Copyright © 2015–2016 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 #-} {-# OPTIONS -fno-warn-orphans #-} module Error (tests) where import Data.Function (on) import Data.List (isInfixOf) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import Test.Framework import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, (@?=)) import Test.QuickCheck import Text.Megaparsec.Error import Text.Megaparsec.Pos import Util () #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable, all) import Data.Monoid (mempty) import Prelude hiding (all) #endif tests :: Test tests = testGroup "Parse errors" [ testProperty "monoid left identity" prop_monoid_left_id , testProperty "monoid right identity" prop_monoid_right_id , testProperty "monoid associativity" prop_monoid_assoc , testProperty "consistency of Show/Read" prop_showReadConsistency , testProperty "position of merged error" prop_mergeErrorPos , testProperty "unexpected items in merged error" prop_mergeErrorUnexpected , testProperty "expected items in merged error" prop_mergeErrorExpected , testProperty "custom items in merged error" prop_mergeErrorCustom , testCase "showTokens (String instance)" case_showTokens , testCase "rendering of unknown parse error" case_ppUnknownError , testProperty "source position in rendered error" prop_ppSourcePos , testProperty "unexpected items in rendered error" prop_ppUnexpected , testProperty "expected items in rendered error" prop_ppExpected , testProperty "custom data in rendered error" prop_ppCustom ] type PE = ParseError Char Dec prop_monoid_left_id :: PE -> Property prop_monoid_left_id x = mempty <> x === x .&&. mempty { errorPos = errorPos x } <> x === x prop_monoid_right_id :: PE -> Property prop_monoid_right_id x = x <> mempty === x .&&. mempty { errorPos = errorPos x } <> x === x prop_monoid_assoc :: PE -> PE -> PE -> Property prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z) prop_showReadConsistency :: PE -> Property prop_showReadConsistency x = read (show x) === x prop_mergeErrorPos :: PE -> PE -> Property prop_mergeErrorPos e1 e2 = errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2) prop_mergeErrorUnexpected :: PE -> PE -> Property prop_mergeErrorUnexpected = checkMergedItems errorUnexpected prop_mergeErrorExpected :: PE -> PE -> Property prop_mergeErrorExpected = checkMergedItems errorExpected prop_mergeErrorCustom :: PE -> PE -> Property prop_mergeErrorCustom = checkMergedItems errorCustom checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property checkMergedItems f e1 e2 = f (e1 <> e2) === r where r = case (compare `on` errorPos) e1 e2 of LT -> f e2 EQ -> (E.union `on` f) e1 e2 GT -> f e1 case_showTokens :: Assertion case_showTokens = mapM_ (\(x,y) -> showTokens (NE.fromList x) @?= y) [ ("\r\n", "crlf newline") , ("\0", "null") , ("\a", "bell") , ("\b", "backspace") , ("\t", "tab") , ("\n", "newline") , ("\v", "vertical tab") , ("\f", "form feed") , ("\r", "carriage return") , (" ", "space") , ("a", "'a'") , ("foo", "\"foo\"") ] case_ppUnknownError :: Assertion case_ppUnknownError = parseErrorPretty (err :: PE) @?= "1:1:\nunknown parse error\n" where err = ParseError { errorPos = initialPos "" :| [] , errorUnexpected = E.empty , errorExpected = E.empty , errorCustom = E.empty } prop_ppSourcePos :: PE -> Property prop_ppSourcePos = checkPresence errorPos sourcePosPretty prop_ppUnexpected :: PE -> Property prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent prop_ppExpected :: PE -> Property prop_ppExpected = checkPresence errorExpected showErrorComponent prop_ppCustom :: PE -> Property prop_ppCustom = checkPresence errorCustom showErrorComponent checkPresence :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property checkPresence g r e = property (all f (g e)) where rendered = parseErrorPretty e f x = r x `isInfixOf` rendered megaparsec-5.0.1/tests/Expr.hs0000644000000000000000000001510712710173312014427 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's expression parsers. -- -- Copyright © 2015–2016 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 #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Expr (tests) where import Control.Applicative (some, (<|>)) import Data.Char (isDigit, digitToInt) 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) #endif tests :: Test tests = testGroup "Expression parsers" [ testProperty "correctness of expression parser" prop_correctness , testProperty "error message on empty input" prop_empty_error , testProperty "error message on missing term" prop_missing_term , testProperty "error message on missing op" prop_missing_op ] -- Algebraic structures to build abstract syntax tree of our expression. data Node = Val Integer -- ^ literal value | Neg Node -- ^ negation (prefix unary) | Fac Node -- ^ factorial (postfix unary) | Mod Node Node -- ^ modulo | Sum Node Node -- ^ summation (addition) | Sub Node Node -- ^ subtraction | Pro Node Node -- ^ product | Div Node Node -- ^ division | Exp Node Node -- ^ exponentiation deriving (Eq, Show) instance Enum Node where fromEnum (Val _) = 0 fromEnum (Neg _) = 0 fromEnum (Fac _) = 0 fromEnum (Mod _ _) = 0 fromEnum (Exp _ _) = 1 fromEnum (Pro _ _) = 2 fromEnum (Div _ _) = 2 fromEnum (Sum _ _) = 3 fromEnum (Sub _ _) = 3 toEnum _ = error "Oops!" instance Ord Node where x `compare` y = fromEnum x `compare` fromEnum y showNode :: Node -> String showNode (Val x) = show x showNode n@(Neg x) = "-" ++ showGT n x showNode n@(Fac x) = showGT n x ++ "!" showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y showGT :: Node -> Node -> String showGT parent node = (if node > parent then showCmp else showNode) node showGE :: Node -> Node -> String showGE parent node = (if node >= parent then showCmp else showNode) node showCmp :: Node -> String showCmp node = (if fromEnum node == 0 then showNode else inParens) node inParens :: Node -> String inParens x = "(" ++ showNode x ++ ")" instance Arbitrary Node where arbitrary = sized arbitraryN0 arbitraryN0 :: Int -> Gen Node arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf) , (9, arbitraryN1 n) ] where leaf = arbitraryN1 (n `div` 2) arbitraryN1 :: Int -> Gen Node arbitraryN1 n = frequency [ (1, Neg <$> arbitraryN2 n) , (1, Fac <$> arbitraryN2 n) , (7, arbitraryN2 n)] arbitraryN2 :: Int -> Gen Node arbitraryN2 0 = Val . getNonNegative <$> arbitrary arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf where leaf = arbitraryN0 (n `div` 2) -- Some helpers are put here since we don't want to depend on -- "Text.Megaparsec.Lexer". lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a lexeme p = p <* hidden space symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String symbol = lexeme . string parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a parens = between (symbol "(") (symbol ")") integer :: (MonadParsec e s m, Token s ~ 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 e s m, Token s ~ Char) => m Node expr = makeExprParser term table term :: (MonadParsec e s m, Token s ~ Char) => m Node term = parens expr <|> (Val <$> integer) "term" table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]] table = [ [ Prefix (symbol "-" *> pure Neg) , Postfix (symbol "!" *> pure Fac) , InfixN (symbol "%" *> pure Mod) ] , [ InfixR (symbol "^" *> pure Exp) ] , [ InfixL (symbol "*" *> pure Pro) , InfixL (symbol "/" *> pure Div) ] , [ InfixL (symbol "+" *> pure Sum) , InfixL (symbol "-" *> pure Sub)] ] prop_correctness :: Node -> Property prop_correctness node = checkParser expr (Right node) (showNode node) prop_empty_error :: Property prop_empty_error = checkParser expr r s where r = posErr 0 s [ueof, elabel "term"] s = "" prop_missing_term :: Char -> Property prop_missing_term c = checkParser expr r s where r | c `elem` "-(" = posErr 1 s [ueof, elabel "term"] | isDigit c = Right . Val . fromIntegral . digitToInt $ c | otherwise = posErr 0 s [utok c, elabel "term"] s = pure c prop_missing_op :: Node -> Node -> Property prop_missing_op a b = checkParser expr r s where a' = inParens a c = s !! n n = succ $ length a' r | c == '-' = Right $ Sub a b | otherwise = posErr n s [utok c, eeof, elabel "operator"] s = a' ++ " " ++ inParens b megaparsec-5.0.1/tests/Lexer.hs0000644000000000000000000003417012714654562014610 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's lexer. -- -- Copyright © 2015–2016 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 #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Lexer (tests) where import Control.Applicative (empty) import Control.Monad (void) import Data.Char ( readLitChar , showLitChar , isDigit , isAlphaNum , isSpace , toLower ) import Data.List (findIndices, isInfixOf, find) import Data.Maybe import Data.Scientific (fromFloatDigits) import Numeric (showInt, showHex, showOct, showSigned) import Test.Framework import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion) 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>), (<$)) #endif tests :: Test tests = testGroup "Lexer" [ testProperty "space combinator" prop_space , testProperty "symbol combinator" prop_symbol , testProperty "symbol' combinator" prop_symbol' , testCase "skipBlockCommentNested" case_skipBlockCommentNested , testProperty "indentLevel" prop_indentLevel , testProperty "incorrectIndent" prop_incorrectIndent , testProperty "indentGuard combinator" prop_indentGuard , testProperty "nonIndented combinator" prop_nonIndented , testProperty "indentBlock combinator" prop_indentBlock , testProperty "indentBlock (many)" prop_indentMany , testProperty "lineFold" prop_lineFold , testProperty "charLiteral" prop_charLiteral , testProperty "integer" prop_integer , testProperty "decimal" prop_decimal , testProperty "hexadecimal" prop_hexadecimal , testProperty "octal" prop_octal , testProperty "float 0" prop_float_0 , testProperty "float 1" prop_float_1 , testProperty "number 0" prop_number_0 , testProperty "number 1" prop_number_1 , testProperty "number 2 (signed)" prop_number_2 , testProperty "signed" prop_signed ] -- White space mkWhiteSpace :: Gen String mkWhiteSpace = concat <$> listOf whiteUnit where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock] mkSymbol :: Gen String mkSymbol = (++) <$> symbolName <*> whiteChars mkInterspace :: String -> Int -> Gen String mkInterspace x n = oneof [si, mkIndent x n] where si = (++ x) <$> listOf (elements " \t") mkIndent :: String -> Int -> Gen String mkIndent x n = (++) <$> mkIndent' x n <*> eol where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))] mkIndent' :: String -> Int -> Gen String mkIndent' x n = concat <$> sequence [spc, sym, tra] where spc = frequency [(5, vectorOf n itm), (1, listOf itm)] tra = listOf itm itm = elements " \t" sym = return x whiteChars :: Gen String whiteChars = listOf (elements "\t\n ") whiteLine :: Gen String whiteLine = commentOut <$> arbitrary `suchThat` goodEnough where commentOut x = "//" ++ x ++ "\n" goodEnough x = '\n' `notElem` x whiteBlock :: Gen String whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough where commentOut x = "/*" ++ x ++ "*/" goodEnough x = not $ "*/" `isInfixOf` x symbolName :: Gen String symbolName = listOf $ arbitrary `suchThat` isAlphaNum sc :: Parser () sc = space (void $ C.oneOf " \t") empty empty scn :: Parser () scn = space (void C.spaceChar) l b where l = skipLineComment "//" b = skipBlockComment "/*" "*/" prop_space :: Property prop_space = forAll mkWhiteSpace (checkParser p r) where p = scn r = Right () prop_symbol :: Maybe Char -> Property prop_symbol t = forAll mkSymbol $ \s -> parseSymbol (symbol scn) id s t prop_symbol' :: Maybe Char -> Property prop_symbol' t = forAll mkSymbol $ \s -> parseSymbol (symbol' scn) (fmap toLower) s t parseSymbol :: (String -> Parser String) -> (String -> String) -> String -> 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 [utok (last s), eeof] g = takeWhile (not . isSpace) s s = s' ++ maybeToList t case_skipBlockCommentNested :: Assertion case_skipBlockCommentNested = checkCase p r s where p = space (void C.spaceChar) empty (skipBlockCommentNested "/*" "*/") <* eof r = Right () s = " /* foo bar /* baz */ quux */ " -- Indentation prop_indentLevel :: SourcePos -> Property prop_indentLevel pos = p /=\ sourceColumn pos where p = setPosition pos >> indentLevel prop_incorrectIndent :: Ordering -> Pos -> Pos -> Property prop_incorrectIndent ord ref actual = checkParser p r s where p = incorrectIndent ord ref actual :: Parser () r = posErr 0 s (ii ord ref actual) s = "" prop_indentGuard :: NonNegative (Small Int) -> Property prop_indentGuard n = forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> let r | col0 <= pos1 = posErr 0 s (ii GT pos1 col0) | col1 /= col0 = posErr (getIndent l1 + g 1) s (ii EQ col0 col1) | col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2) | otherwise = Right () (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) fragments = [l0,l1,l2] g x = sum (length <$> take x fragments) s = concat fragments in checkParser p r s where mki = mkIndent sbla (getSmall $ getNonNegative n) p = ip GT pos1 >>= \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn ip = indentGuard scn sp = void (symbol sc sbla <* C.eol) prop_nonIndented :: Property prop_nonIndented = forAll (mkIndent sbla 0) $ \s -> let i = getIndent s r | i == 0 = Right sbla | otherwise = posErr i s (ii EQ pos1 (getCol s)) in checkParser p r s where p = nonIndented scn (symbol scn sbla) prop_indentBlock :: Maybe (Positive (Small Int)) -> Property prop_indentBlock mn'' = forAll mkBlock $ \(l0,l1,l2,l3,l4) -> let r | col1 <= col0 = posErr (getIndent l1 + g 1) s [utok (head sblb), eeof] | isJust mn && col1 /= ib' = posErr (getIndent l1 + g 1) s (ii EQ ib' col1) | col2 <= col1 = posErr (getIndent l2 + g 2) s (ii GT col1 col2) | col3 == col2 = posErr (getIndent l3 + g 3) s [utok (head sblb), etoks sblc] | col3 <= col0 = posErr (getIndent l3 + g 3) s [utok (head sblb), eeof] | col3 < col1 = posErr (getIndent l3 + g 3) s (ii EQ col1 col3) | col3 > col1 = posErr (getIndent l3 + g 3) s (ii EQ col2 col3) | col4 <= col3 = posErr (getIndent l4 + g 4) s (ii GT col3 col4) | otherwise = Right (sbla, [(sblb, [sblc]), (sblb, [sblc])]) (col0, col1, col2, col3, col4) = (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4) fragments = [l0,l1,l2,l3,l4] g x = sum (length <$> take x fragments) s = concat fragments in checkParser p r s where mkBlock = do l0 <- mkIndent sbla 0 l1 <- mkIndent sblb ib l2 <- mkIndent sblc (ib + 2) l3 <- mkIndent sblb ib l4 <- mkIndent' sblc (ib + 2) return (l0,l1,l2,l3,l4) p = lvla lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb lvlc = indentBlock scn $ IndentNone sblc <$ b sblc b = symbol sc l x = return . (x,) mn' = getSmall . getPositive <$> mn'' mn = unsafePos . fromIntegral <$> mn' ib = fromMaybe 2 mn' ib' = unsafePos (fromIntegral ib) prop_indentMany :: Property prop_indentMany = forAll (mkIndent sbla 0) (checkParser p r) where r = Right (sbla, []) p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb b = symbol sc l x = return . (x,) prop_lineFold :: Property prop_lineFold = forAll mkFold $ \(l0,l1,l2) -> let r | end0 && col1 <= col0 = posErr (getIndent l1 + g 1) s (ii GT col0 col1) | end1 && col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2) | otherwise = Right (sbla, sblb, sblc) (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) (end0, end1) = (getEnd l0, getEnd l1) fragments = [l0,l1,l2] g x = sum (length <$> take x fragments) s = concat fragments in checkParser p r s where mkFold = do l0 <- mkInterspace sbla 0 l1 <- mkInterspace sblb 1 l2 <- mkInterspace sblc 1 return (l0,l1,l2) p = lineFold scn $ \sc' -> do a <- symbol sc' sbla b <- symbol sc' sblb c <- symbol scn sblc return (a, b, c) getEnd x = last x == '\n' getIndent :: String -> Int getIndent = length . takeWhile isSpace getCol :: String -> Pos getCol x = sourceColumn . updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x sbla, sblb, sblc :: String sbla = "aaa" sblb = "bbb" sblc = "ccc" ii :: Ordering -> Pos -> Pos -> [EC] ii ord ref actual = [cstm (DecIndentation ord ref actual)] pos1 :: Pos pos1 = unsafePos 1 -- Character and string literals 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 $ elabel "literal character" : [ if null s then ueof else utok (head s) ] | null g = Right h | otherwise = posErr l s [utok (head g), eeof] l = length s - length g s = if null t || i then t else showLitChar (head t) (tail t) -- Numbers 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 [ueof, elabel "floating point number"] | otherwise = posErr (length s) s [ueof, etok '.', etok 'E', etok 'e', elabel "digit"] s = maybe "" (show . getNonNegative) n' prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property prop_number_0 n' = checkParser number r s where r = Right $ case n' of Left x -> fromIntegral . getNonNegative $ x Right x -> fromFloatDigits . getNonNegative $ x s = either (show . getNonNegative) (show . getNonNegative) n' prop_number_1 :: Property prop_number_1 = checkParser number r s where r = posErr 0 s [ueof, elabel "number"] s = "" prop_number_2 :: Either Integer Double -> Property prop_number_2 n = checkParser p r s where p = signed (hidden C.space) number r = Right $ case n of Left x -> fromIntegral x Right x -> fromFloatDigits x s = either show show n prop_signed :: Integer -> Int -> Bool -> Property prop_signed n i plus = checkParser p r s where p = signed (hidden C.space) integer r | i > length z = Right n | otherwise = posErr i s $ utok '?' : (if i <= 0 then [etok '+', etok '-'] else []) ++ [elabel $ if isNothing . find isDigit $ take i s then "integer" else "rest of integer"] ++ [eeof | 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 Char Dec) Integer, String) quasiCorrupted n' i shower l = (r, s) where n = getNonNegative n' r | i > length z = Right n | otherwise = posErr i s $ utok '?' : [ eeof | i > 0 ] ++ [if i <= 0 || null l then elabel l else elabel $ "rest of " ++ l] z = shower n "" s = if i <= length z then take i z ++ "?" ++ drop i z else z megaparsec-5.0.1/tests/Perm.hs0000644000000000000000000000752312710173312014417 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's permutation phrases parsers. -- -- Copyright © 2015–2016 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.List (nub, elemIndices) import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Lexer (integer) 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 , testProperty "combinator (<$$>)" prop_ddcomb ] 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 $ [utok b, eeof] ++ [etok a | a `notElem` preb] ++ [etok c | c `notElem` preb] | length cis > 1 = posErr (cis !! 1) s $ [utok c] ++ [etok a | a `notElem` prec] ++ [if b `elem` prec then eeof else etok b] | b `notElem` s = posErr (length s) s $ [ueof, etok b] ++ [etok a | a `notElem` s || last s == a] ++ [etok c | c `notElem` s] | otherwise = Right ( if a `elem` s then filter (== a) s else a' , b , if c `elem` s then c else c' ) bis = elemIndices b s preb = take (bis !! 1) s cis = elemIndices c s prec = take (cis !! 1) s s = getInput v prop_ddcomb :: NonNegative Integer -> Property prop_ddcomb n' = checkParser (makePermParser p) r s where p = succ <$$> integer r = Right (succ n) n = getNonNegative n' s = show n megaparsec-5.0.1/tests/Pos.hs0000644000000000000000000001107712711107672014263 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's textual source positions. -- -- Copyright © 2015–2016 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 #-} {-# OPTIONS -fno-warn-orphans #-} module Pos (tests) where import Control.Monad.Catch import Data.Function (on) import Data.List (isInfixOf, elemIndices) import Data.Semigroup ((<>)) import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import Text.Megaparsec.Pos import Util (updatePosString) #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif tests :: Test tests = testGroup "Textual source positions" [ testProperty "creation of Pos (mkPos)" prop_mkPos , testProperty "creation of Pos (unsafePos)" prop_unsafePos , testProperty "consistency of Show/Read for Pos" prop_showReadPos , testProperty "Ord instance of Pos" prop_ordPos , testProperty "Semigroup instance of Pos" prop_semigroupPos , testProperty "construction of initial position" prop_initialPos , testProperty "consistency of Show/Read for SourcePos" prop_showReadSourcePos , testProperty "pretty-printing: visible file path" prop_ppFilePath , testProperty "pretty-printing: visible line" prop_ppLine , testProperty "pretty-printing: visible column" prop_ppColumn , testProperty "default updating of source position" prop_defaultUpdatePos ] prop_mkPos :: Word -> Property prop_mkPos x' = case mkPos x' of Left e -> fromException e === Just InvalidPosException Right x -> unPos x === x' prop_unsafePos :: Positive Word -> Property prop_unsafePos x' = unPos (unsafePos x) === x where x = getPositive x' prop_showReadPos :: Pos -> Property prop_showReadPos x = read (show x) === x prop_ordPos :: Pos -> Pos -> Property prop_ordPos x y = compare x y === (compare `on` unPos) x y prop_semigroupPos :: Pos -> Pos -> Property prop_semigroupPos x y = x <> y === unsafePos (unPos x + unPos y) .&&. unPos (x <> y) === unPos x + unPos y prop_initialPos :: String -> Property prop_initialPos fp = sourceName x === fp .&&. sourceLine x === unsafePos 1 .&&. sourceColumn x === unsafePos 1 where x = initialPos fp prop_showReadSourcePos :: SourcePos -> Property prop_showReadSourcePos x = read (show x) === x prop_ppFilePath :: SourcePos -> Property prop_ppFilePath x = property $ sourceName x `isInfixOf` sourcePosPretty x prop_ppLine :: SourcePos -> Property prop_ppLine x = property $ (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x prop_ppColumn :: SourcePos -> Property prop_ppColumn x = property $ (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x prop_defaultUpdatePos :: Pos -> SourcePos -> String -> Property prop_defaultUpdatePos w pos "" = updatePosString w pos "" === pos prop_defaultUpdatePos w pos s = sourceName updated === sourceName pos .&&. unPos (sourceLine updated) === unPos (sourceLine pos) + inclines .&&. cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` unPos w == 0)) where updated = updatePosString w pos s cols = unPos (sourceColumn updated) newlines = elemIndices '\n' s inclines = fromIntegral (length newlines) total = fromIntegral (length s) mincols = if null newlines then total + unPos (sourceColumn pos) else total - fromIntegral (maximum newlines) megaparsec-5.0.1/tests/Prim.hs0000644000000000000000000011721612714654562014443 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec's primitive parser combinators. -- -- Copyright © 2015–2016 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 FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-orphans #-} module Prim (tests) where import Control.Applicative import Control.Monad.Cont import Control.Monad.Except import Control.Monad.Identity import Control.Monad.Reader import Data.Char (isLetter, toUpper, chr) import Data.Foldable (asum) import Data.List (isPrefixOf, foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (maybeToList, fromMaybe) import Data.Proxy import Data.Set (Set) import Data.Word (Word8) import Prelude hiding (span) import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L import qualified Control.Monad.Writer.Strict as S import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Test.Framework import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck hiding (label) import Test.HUnit (Assertion) import Text.Megaparsec.Char import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String import Pos () import Error () import Util tests :: Test tests = testGroup "Primitive parser combinators" [ testProperty "Stream lazy byte string" prop_byteStringL , testProperty "Stream lazy byte string (pos)" prop_byteStringL_pos , testProperty "Stream strict byte string" prop_byteStringS , testProperty "Stream strict byte string (pos)" prop_byteStringS_pos , testProperty "Stream lazy text" prop_textL , testProperty "Stream lazy text (pos)" prop_textL_pos , testProperty "Stream strict text" prop_textS , testProperty "Stream strict text (pos)" prop_textS_pos , testProperty "position in custom stream, eof" prop_cst_eof , testProperty "position in custom stream, token" prop_cst_token , testProperty "position in custom stream, tokens" prop_cst_tokens , testProperty "ParsecT functor" prop_functor , testProperty "ParsecT applicative (<*>)" prop_applicative_0 , testProperty "ParsecT applicative (<*>) meok-cerr" prop_applicative_1 , testProperty "ParsecT applicative (*>)" prop_applicative_2 , testProperty "ParsecT applicative (<*)" prop_applicative_3 , 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 "ParsecT monad laws: left identity" prop_monad_left_id , testProperty "ParsecT monad laws: right identity" prop_monad_right_id , testProperty "ParsecT monad laws: associativity" prop_monad_assoc , testProperty "ParsecT monad io (liftIO)" prop_monad_io , testProperty "ParsecT monad reader ask" prop_monad_reader_ask , testProperty "ParsecT monad reader local" prop_monad_reader_local , testProperty "ParsecT monad state get" prop_monad_state_get , testProperty "ParsecT monad state put" prop_monad_state_put , testProperty "ParsecT monad cont" prop_monad_cont , testProperty "ParsecT monad error: throw" prop_monad_error_throw , testProperty "ParsecT monad error: catch" prop_monad_error_catch , testProperty "combinator unexpected" prop_unexpected , testProperty "combinator failure" prop_failure , testProperty "combinator label" prop_label , testProperty "combinator hidden hints" prop_hidden_0 , testProperty "combinator hidden error" prop_hidden_1 , testProperty "combinator try" prop_try , testProperty "combinator lookAhead" prop_lookAhead_0 , testProperty "combinator lookAhead hints" prop_lookAhead_1 , testProperty "combinator lookAhead messages" prop_lookAhead_2 , testCase "combinator lookAhead cerr" case_lookAhead_3 , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1 , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 , testCase "combinator notFollowedBy cerr" case_notFollowedBy_3a , testCase "combinator notFollowedBy cerr" case_notFollowedBy_3b , testCase "combinator notFollowedBy eerr" case_notFollowedBy_4a , testCase "combinator notFollowedBy eerr" case_notFollowedBy_4b , testProperty "combinator withRecovery" prop_withRecovery_0 , testCase "combinator withRecovery eok" case_withRecovery_1 , testCase "combinator withRecovery meerr-rcerr" case_withRecovery_2 , testCase "combinator withRecovery meerr-reok" case_withRecovery_3a , testCase "combinator withRecovery meerr-reok" case_withRecovery_3b , testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4a , testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4b , testCase "combinator withRecovery mcerr-rcerr" case_withRecovery_5 , testCase "combinator withRecovery mcerr-reok" case_withRecovery_6a , testCase "combinator withRecovery mcerr-reok" case_withRecovery_6b , testCase "combinator withRecovery mcerr-reerr" case_withRecovery_7 , testCase "combinator eof return value" case_eof , testProperty "combinator token" prop_token , testProperty "combinator tokens" prop_tokens_0 , testProperty "combinator tokens (consumption)" prop_tokens_1 , testProperty "parser state position" prop_state_pos , testProperty "parser state position (push)" prop_state_pushPosition , testProperty "parser state position (pop)" prop_state_popPosition , testProperty "parser state input" prop_state_input , testProperty "parser state tab width" prop_state_tab , testProperty "parser state general" prop_state , testProperty "parseMaybe" prop_parseMaybe , testProperty "custom state parsing" prop_runParser' , testProperty "custom state parsing (transformer)" prop_runParserT' , testProperty "state on failure (mplus)" prop_stOnFail_0 , testProperty "state on failure (tab)" prop_stOnFail_1 , testProperty "state on failure (eof)" prop_stOnFail_2 , testProperty "state on failure (notFollowedBy)" prop_stOnFail_3 , 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 a => Arbitrary (State a) where arbitrary = State <$> arbitrary <*> arbitrary <*> (unsafePos <$> choose (1, 20)) -- Various instances of Stream prop_byteStringL :: Word8 -> NonNegative Int -> Property prop_byteStringL ch' n = parse p "" (BL.pack s) === Right s where p = many (char ch) :: Parsec Dec BL.ByteString String s = replicate (getNonNegative n) ch ch = byteToChar ch' prop_byteStringL_pos :: Pos -> SourcePos -> Char -> Property prop_byteStringL_pos w pos ch = updatePos (Proxy :: Proxy String) w pos ch === updatePos (Proxy :: Proxy BL.ByteString) w pos ch prop_byteStringS :: Word8 -> NonNegative Int -> Property prop_byteStringS ch' n = parse p "" (B.pack s) === Right s where p = many (char ch) :: Parsec Dec B.ByteString String s = replicate (getNonNegative n) ch ch = byteToChar ch' prop_byteStringS_pos :: Pos -> SourcePos -> Char -> Property prop_byteStringS_pos w pos ch = updatePos (Proxy :: Proxy String) w pos ch === updatePos (Proxy :: Proxy B.ByteString) w pos ch byteToChar :: Word8 -> Char byteToChar = chr . fromIntegral prop_textL :: Char -> NonNegative Int -> Property prop_textL ch n = parse p "" (TL.pack s) === Right s where p = many (char ch) :: Parsec Dec TL.Text String s = replicate (getNonNegative n) ch prop_textL_pos :: Pos -> SourcePos -> Char -> Property prop_textL_pos w pos ch = updatePos (Proxy :: Proxy String) w pos ch === updatePos (Proxy :: Proxy TL.Text) w pos ch prop_textS :: Char -> NonNegative Int -> Property prop_textS ch n = parse p "" (T.pack s) === Right s where p = many (char ch) :: Parsec Dec T.Text String s = replicate (getNonNegative n) ch prop_textS_pos :: Pos -> SourcePos -> Char -> Property prop_textS_pos w pos ch = updatePos (Proxy :: Proxy String) w pos ch === updatePos (Proxy :: Proxy T.Text) w pos ch -- Custom stream of tokens and position advancing -- | This data type will represent tokens in input stream for the purposes -- of next several tests. data Span = Span { spanStart :: SourcePos , spanEnd :: SourcePos , spanBody :: NonEmpty Char } deriving (Eq, Ord, Show) instance Stream [Span] where type Token [Span] = Span uncons [] = Nothing uncons (t:ts) = Just (t, ts) updatePos _ _ _ (Span start end _) = (start, end) instance Arbitrary Span where arbitrary = do start <- arbitrary end <- arbitrary `suchThat` (> start) Span start end <$> arbitrary type CustomParser = Parsec Dec [Span] prop_cst_eof :: State [Span] -> Property prop_cst_eof st = (not . null . stateInput) st ==> (runParser' p st === r) where p = eof :: CustomParser () h = head (stateInput st) apos = let (_:|z) = statePos st in spanStart h :| z r = (st { statePos = apos }, Left ParseError { errorPos = apos , errorUnexpected = E.singleton (Tokens (nes h)) , errorExpected = E.singleton EndOfInput , errorCustom = E.empty }) prop_cst_token :: State [Span] -> Span -> Property prop_cst_token st@State {..} span = runParser' p st === r where p = pSpan span h = head stateInput (apos, npos) = let z = NE.tail statePos in (spanStart h :| z, spanEnd h :| z) r | null stateInput = ( st , Left ParseError { errorPos = statePos , errorUnexpected = E.singleton EndOfInput , errorExpected = E.singleton (Tokens $ nes span) , errorCustom = E.empty } ) | spanBody h == spanBody span = ( st { statePos = npos , stateInput = tail stateInput } , Right span ) | otherwise = ( st { statePos = apos } , Left ParseError { errorPos = apos , errorUnexpected = E.singleton (Tokens $ nes h) , errorExpected = E.singleton (Tokens $ nes span) , errorCustom = E.empty } ) pSpan :: Span -> CustomParser Span pSpan span = token testToken (Just span) where f = E.singleton . Tokens . nes testToken x = if spanBody x == spanBody span then Right span else Left (f x, f span , E.empty) prop_cst_tokens :: State [Span] -> [Span] -> Property prop_cst_tokens st' ts = forAll (incCoincidence st' ts) $ \st@State {..} -> let p = tokens compareTokens ts :: CustomParser [Span] compareTokens x y = spanBody x == spanBody y updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth ts' = NE.fromList ts il = length . takeWhile id $ zipWith compareTokens stateInput ts tl = length ts consumed = take il stateInput (apos, npos) = let (pos:|z) = statePos in ( spanStart (head stateInput) :| z , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) r | null ts = (st, Right []) | null stateInput = ( st , Left ParseError { errorPos = statePos , errorUnexpected = E.singleton EndOfInput , errorExpected = E.singleton (Tokens ts') , errorCustom = E.empty } ) | il == tl = ( st { statePos = npos , stateInput = drop (length ts) stateInput } , Right consumed ) | otherwise = ( st { statePos = apos } , Left ParseError { errorPos = apos , errorUnexpected = E.singleton (Tokens . NE.fromList $ take (il + 1) stateInput) , errorExpected = E.singleton (Tokens ts') , errorCustom = E.empty } ) in runParser' p st === r incCoincidence :: State [Span] -> [Span] -> Gen (State [Span]) incCoincidence st ts = do n <- getSmall <$> arbitrary let (pre, post) = splitAt n (stateInput st) pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts return st { stateInput = pre' ++ post } -- 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 :: Char -> Char -> Property prop_applicative_1 a b = a /= b ==> checkParser p r s where p = pure toUpper <*> (char a >> char a) r = posErr 1 s [utok b, etok a] s = [a,b] prop_applicative_2 :: Integer -> Integer -> Property prop_applicative_2 n m = (pure n *> pure m) /=\ m prop_applicative_3 :: Integer -> Integer -> Property prop_applicative_3 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 [utok (head s1), eeof]) s1 | s0 `isPrefixOf` s1 = checkParser p (posErr s0l s1 [utok (s1 !! s0l), eeof]) s1 | otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1 where p = 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 [utok c, eeof] | a == c = Right a | otherwise = posErr 1 s [utok c, etok a] s = if l then [a] else [b,c] prop_alternative_3 :: Property prop_alternative_3 = checkParser p r s where p = asum [empty, string ">>>", empty, return "foo"] "bar" p' = bsum [empty, 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 $ [utok 'c', etok 'b', eeof] ++ [etok '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 [ueof, etok 'a'] | a == 0 = posErr 0 s [utok (head s), etok 'a'] | b == 0 = posErr a s $ [etok 'a', etok 'b'] ++ if c > 0 then [utok 'c'] else [ueof] | c > 0 = posErr (a + b) s [utok 'c', etok 'b', eeof] | 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 $ [utok 'c', eeof] ++ [etok 'a' | not a && not b] ++ [etok '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 msg = checkParser p r s where p = fail msg :: Parser () r = posErr 0 s [cstm (DecFail msg)] s = "" prop_monad_left_id :: Integer -> Integer -> Property prop_monad_left_id a b = (return a >>= f) !=! f a where f x = return $ x + b prop_monad_right_id :: Integer -> Property prop_monad_right_id a = (m >>= return) !=! m where m = return a prop_monad_assoc :: Integer -> Integer -> Integer -> Property prop_monad_assoc a b c = ((m >>= f) >>= g) !=! (m >>= (\x -> f x >>= g)) where m = return a f x = return $ x + b g x = return $ x + c -- MonadIO instance prop_monad_io :: Integer -> Property prop_monad_io n = ioProperty (liftM (=== Right n) (runParserT p "" "")) where p = liftIO (return n) :: ParsecT Dec String IO Integer -- MonadReader instance prop_monad_reader_ask :: Integer -> Property prop_monad_reader_ask a = runReader (runParserT p "" "") a === Right a where p = ask :: ParsecT Dec String (Reader Integer) Integer prop_monad_reader_local :: Integer -> Integer -> Property prop_monad_reader_local a b = runReader (runParserT p "" "") a === Right (a + b) where p = local (+ b) ask :: ParsecT Dec String (Reader Integer) Integer -- MonadState instance prop_monad_state_get :: Integer -> Property prop_monad_state_get a = L.evalState (runParserT p "" "") a === Right a where p = L.get :: ParsecT Dec String (L.State Integer) Integer prop_monad_state_put :: Integer -> Integer -> Property prop_monad_state_put a b = L.execState (runParserT p "" "") a === b where p = L.put b :: ParsecT Dec String (L.State Integer) () -- MonadCont instance prop_monad_cont :: Integer -> Integer -> Property prop_monad_cont a b = runCont (runParserT p "" "") id === Right (max a b) where p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer p = do x <- callCC $ \e -> when (a > b) (e a) >> return b return x -- MonadError instance prop_monad_error_throw :: Integer -> Integer -> Property prop_monad_error_throw a b = runExcept (runParserT p "" "") === Left a where p :: ParsecT Dec String (Except Integer) Integer p = throwError a >> return b prop_monad_error_catch :: Integer -> Integer -> Property prop_monad_error_catch a b = runExcept (runParserT p "" "") === Right (Right $ a + b) where p :: ParsecT Dec String (Except Integer) Integer p = (throwError a >> return b) `catchError` handler handler e = return (e + b) -- Primitive combinators prop_unexpected :: ErrorItem Char -> Property prop_unexpected item = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = unexpected item r = posErr 0 s [Unexpected item] s = "" prop_failure :: Set (ErrorItem Char) -> Set (ErrorItem Char) -> Set Dec -> Property prop_failure us ps xs = checkParser' p r s where p :: (MonadParsec Dec s m, Token s ~ Char) => m String p = failure us ps xs r = Left ParseError { errorPos = nes (initialPos "") , errorUnexpected = us , errorExpected = ps , errorCustom = xs } s = "" prop_label :: NonNegative Int -> NonNegative Int -> NonNegative Int -> String -> Property prop_label a' b' c' l = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = (++) <$> many (char 'a') <*> (many (char 'b') l) r | null s = Right s | c > 0 = posErr (a + b) s $ [utok 'c', eeof] ++ [etok 'a' | b == 0] ++ (if null l then [] else [if b == 0 then elabel l else elabel ("rest of " ++ l)]) | otherwise = Right s s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] prop_hidden_0 :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_hidden_0 a' b' c' = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = (++) <$> many (char 'a') <*> hidden (many (char 'b')) r | null s = Right s | c > 0 = posErr (a + b) s $ [utok 'c', eeof] ++ [etok 'a' | b == 0] | otherwise = Right s s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] prop_hidden_1 :: NonEmptyList Char -> String -> Property prop_hidden_1 c' s = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m (Maybe String) p = optional (hidden $ string c) r | null s = Right Nothing | c == s = Right (Just s) | c `isPrefixOf` s = posErr cn s [utok (s !! cn), eeof] | otherwise = posErr 0 s [utok (head s), eeof] c = getNonEmpty c' cn = length c prop_try :: Char -> Char -> Char -> Property prop_try pre ch1 ch2 = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = try (sequence [char pre, char ch1]) <|> sequence [char pre, char ch2] r = posErr 1 s [ueof, etok ch1, etok ch2] s = [pre] prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property prop_lookAhead_0 a b c = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m Char p = do l <- lookAhead (oneOf "ab" "label") guard (l == h) char 'a' h = head s r | null s = posErr 0 s [ueof, elabel "label"] | s == "a" = Right 'a' | h == 'b' = posErr 0 s [utok 'b', etok 'a'] | h == 'c' = posErr 0 s [utok 'c', elabel "label"] | otherwise = posErr 1 s [utok (s !! 1), eeof] s = abcRow a b c prop_lookAhead_1 :: String -> Property prop_lookAhead_1 s = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m () p = lookAhead (some letterChar) >> fail emsg h = head s r | null s = posErr 0 s [ueof, elabel "letter"] | isLetter h = posErr 0 s [cstm (DecFail emsg)] | otherwise = posErr 0 s [utok h, elabel "letter"] emsg = "ops!" prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property prop_lookAhead_2 a b c = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m Char p = lookAhead (some (char 'a')) >> char 'b' r | null s = posErr 0 s [ueof, etok 'a'] | a = posErr 0 s [utok 'a', etok 'b'] | otherwise = posErr 0 s [utok (head s), etok 'a'] s = abcRow a b c case_lookAhead_3 :: Assertion case_lookAhead_3 = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = lookAhead (char 'a' *> fail emsg) r = posErr 1 s [cstm (DecFail emsg)] emsg = "ops!" s = "abc" prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_notFollowedBy_0 a' b' c' = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c') r | b > 0 = posErr a s [utok 'b', etok 'a'] | otherwise = Right (replicate a 'a') s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_notFollowedBy_1 a' b' c' = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = many (char 'a') <* (notFollowedBy . notFollowedBy) (char 'c') <* many (char 'c') r | b == 0 && c > 0 = Right (replicate a 'a') | b > 0 = posErr a s [utok 'b', etok 'a'] | otherwise = posErr a s [ueof, etok 'a'] s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_notFollowedBy_2 a' b' c' = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = many (char 'a') <* notFollowedBy eof <* many anyChar r | b > 0 || c > 0 = Right (replicate a 'a') | otherwise = posErr a s [ueof, etok 'a'] s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] case_notFollowedBy_3a :: Assertion case_notFollowedBy_3a = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m () p = notFollowedBy (char 'a' *> char 'c') r = Right () s = "ab" case_notFollowedBy_3b :: Assertion case_notFollowedBy_3b = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m () p = notFollowedBy (char 'a' *> char 'd') <* char 'c' r = posErr 0 s [utok 'a', etok 'c'] s = "ab" case_notFollowedBy_4a :: Assertion case_notFollowedBy_4a = checkCase' p r s where p :: MonadParsec e s m => m () p = notFollowedBy mzero r = Right () s = "ab" case_notFollowedBy_4b :: Assertion case_notFollowedBy_4b = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m () p = notFollowedBy mzero <* char 'c' r = posErr 0 s [utok 'a', etok 'c'] s = "ab" prop_withRecovery_0 :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_withRecovery_0 a' b' c' = checkParser' p r s where p :: (MonadParsec Dec s m, Token s ~ Char) => m (Either (ParseError Char Dec) String) p = let g = count' 1 3 . char in v <$> withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c' v (Right x) y = Right (x ++ y) v (Left m) _ = Left m r | a == 0 && b == 0 && c == 0 = posErr 0 s [ueof, etok 'a'] | a == 0 && b == 0 && c > 3 = posErr 0 s [utok 'c', etok 'a'] | a == 0 && b == 0 = posErr 0 s [utok 'c', etok 'a'] | a == 0 && b > 3 = posErr 3 s [utok 'b', etok 'a', etok 'c'] | a == 0 && c == 0 = posErr b s [ueof, etok 'a', etok 'c'] | a == 0 && c > 3 = posErr (b + 3) s [utok 'c', eeof] | a == 0 = Right (posErr 0 s [utok 'b', etok 'a']) | a > 3 = posErr 3 s [utok 'a', etok 'c'] | b == 0 && c == 0 = posErr a s $ [ueof, etok 'c'] ++ ma | b == 0 && c > 3 = posErr (a + 3) s [utok 'c', eeof] | b == 0 = Right (Right s) | otherwise = posErr a s $ [utok 'b', etok 'c'] ++ ma ma = [etok 'a' | a < 3] s = abcRow a b c [a,b,c] = getNonNegative <$> [a',b',c'] case_withRecovery_1 :: Assertion case_withRecovery_1 = checkCase' p r s where p :: MonadParsec e s m => m String p = withRecovery (const $ return "bar") (return "foo") r = Right "foo" s = "abc" case_withRecovery_2 :: Assertion case_withRecovery_2 = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (\_ -> char 'a' *> mzero) (string "cba") r = posErr 0 s [utoks "a", etoks "cba"] s = "abc" case_withRecovery_3a :: Assertion case_withRecovery_3a = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (const $ return "abd") (string "cba") r = Right "abd" s = "abc" case_withRecovery_3b :: Assertion case_withRecovery_3b = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (const $ return "abd") (string "cba") <* char 'd' r = posErr 0 s [utok 'a', etoks "cba", etok 'd'] s = "abc" case_withRecovery_4a :: Assertion case_withRecovery_4a = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (const $ string "bc") (char 'a' *> mzero) r = Right "bc" s = "abc" case_withRecovery_4b :: Assertion case_withRecovery_4b = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (const $ string "bc") (char 'a' *> char 'd' *> pure "foo") <* char 'f' r = posErr 3 s [ueof, etok 'f'] s = "abc" case_withRecovery_5 :: Assertion case_withRecovery_5 = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail emsg) r = posErr 1 s [cstm (DecFail emsg)] emsg = "ops!" s = "abc" case_withRecovery_6a :: Assertion case_withRecovery_6a = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m String p = withRecovery (const $ return "abd") (char 'a' *> mzero) r = Right "abd" s = "abc" case_withRecovery_6b :: Assertion case_withRecovery_6b = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m Char p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f' r = posErr 1 s [utok 'b', etok 'd', etok 'f'] s = "abc" case_withRecovery_7 :: Assertion case_withRecovery_7 = checkCase' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m Char p = withRecovery (const mzero) (char 'a' *> char 'd') r = posErr 1 s [utok 'b', etok 'd'] s = "abc" case_eof :: Assertion case_eof = checkCase' eof (Right ()) "" prop_token :: Maybe Char -> String -> Property prop_token mtok s = checkParser' p r s where p :: (MonadParsec e s m, Token s ~ Char) => m Char p = token testChar mtok testChar x = if isLetter x then Right x else Left (E.singleton (Tokens $ nes x), E.empty, E.empty) h = head s r | null s = posErr 0 s $ ueof : maybeToList (etok <$> mtok) | isLetter h && length s == 1 = Right (head s) | isLetter h && length s > 1 = posErr 1 s [utok (s !! 1), eeof] | otherwise = posErr 0 s [utok h] prop_tokens_0 :: String -> String -> Property prop_tokens_0 a = checkString (tokens (==) a) a (==) prop_tokens_1 :: String -> String -> String -> Property prop_tokens_1 pre post post' = not (post `isPrefixOf` post') ==> (leftover === "" .||. leftover === s) where p :: Parser String p = tokens (==) (pre ++ post) s = pre ++ post' st = stateFromInput s leftover = stateInput . fst $ runParser' p st -- Parser state combinators prop_state_pos :: State String -> SourcePos -> Property prop_state_pos st pos = runParser' p st === r where p = (setPosition pos >> getPosition) :: Parser SourcePos r = (f st pos, Right pos) f (State s (_:|xs) w) y = State s (y:|xs) w prop_state_pushPosition :: State String -> SourcePos -> Property prop_state_pushPosition st pos = fst (runParser' p st) === r where p = pushPosition pos :: Parser () r = st { statePos = NE.cons pos (statePos st) } prop_state_popPosition :: State String -> Property prop_state_popPosition st = fst (runParser' p st) === r where p = popPosition :: Parser () r = st { statePos = fromMaybe pos (snd (NE.uncons pos)) } pos = statePos st 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 :: Pos -> Property prop_state_tab w = p /=\ w where p = setTabWidth w >> getTabWidth prop_state :: State String -> State String -> Property prop_state s1 s2 = checkParser' p r s where p :: MonadParsec Dec String m => m (State String) p = do st <- getParserState guard (st == State s (nes $ initialPos "") defaultTabWidth) setParserState s1 updateParserState (f s2) liftM2 const getParserState (setInput "") f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w r = Right (f s2 s1) s = "" -- Running a parser prop_parseMaybe :: String -> String -> Property prop_parseMaybe s s' = parseMaybe p s === r where p = string s' :: Parser String r = if s == s' then Just s else Nothing prop_runParser' :: State String -> String -> Property prop_runParser' st s = runParser' p st === r where p = string s r = emulateStrParsing st s prop_runParserT' :: State String -> String -> Property prop_runParserT' st s = runIdentity (runParserT' p st) === r where p = string s r = emulateStrParsing st s emulateStrParsing :: State String -> String -> (State String, Either (ParseError Char Dec) String) emulateStrParsing st@(State i (pos:|z) t) s = if l == length s then (State (drop l i) (updatePosString t pos s :| z) t, Right s) else (st, posErr' (pos:|z) (etoks s : [utoks (take (l + 1) i)])) where l = length (takeWhile id $ zipWith (==) s i) -- Additional tests to check returned state on failure prop_stOnFail_0 :: Positive Int -> Positive Int -> Property prop_stOnFail_0 na' nb' = runParser' p (stateFromInput s) === (i, r) where i = let (Left x) = r in State "" (errorPos x) defaultTabWidth na = getPositive na' nb = getPositive nb' p = try (many (char 'a') <* many (char 'b') <* char 'c') <|> (many (char 'a') <* char 'c') r = posErr (na + nb) s [etok 'b', etok 'c', ueof] s = replicate na 'a' ++ replicate nb 'b' prop_stOnFail_1 :: Positive Int -> Pos -> Property prop_stOnFail_1 na' t = runParser' p (stateFromInput s) === (i, r) where i = let (Left x) = r in State "" (errorPos x) t na = getPositive na' p = many (char 'a') <* setTabWidth t <* fail emsg r = posErr na s [cstm (DecFail emsg)] s = replicate na 'a' emsg = "failing now!" prop_stOnFail_2 :: String -> Char -> Property prop_stOnFail_2 s' ch = runParser' p (stateFromInput s) === (i, r) where i = let (Left x) = r in State [ch] (errorPos x) defaultTabWidth r = posErr (length s') s [utok ch, eeof] p = string s' <* eof s = s' ++ [ch] prop_stOnFail_3 :: String -> Property prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r) where i = let (Left x) = r in State s (errorPos x) defaultTabWidth r = posErr 0 s [if null s then ueof else utok (head s)] p = notFollowedBy (string s) stateFromInput :: s -> State s stateFromInput s = State s (nes $ initialPos "") defaultTabWidth -- ReaderT instance of MonadParsec prop_ReaderT_try :: Char -> Char -> Char -> Property prop_ReaderT_try pre ch1 ch2 = checkParser (runReaderT p (s1, s2)) r s where s1 = pre : [ch1] s2 = pre : [ch2] getS1 = asks fst getS2 = asks snd p = try (g =<< getS1) <|> (g =<< getS2) g = sequence . fmap char r = posErr 1 s [ueof, etok ch1, etok ch2] 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 [ueof, etok '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") nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} megaparsec-5.0.1/tests/Util.hs0000644000000000000000000003073112714654562014445 0ustar0000000000000000-- -- QuickCheck tests for Megaparsec, utility functions for parser testing. -- -- Copyright © 2015–2016 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 #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS -fno-warn-orphans #-} module Util ( checkParser , checkParser' , checkCase , checkCase' , simpleParse , checkChar , checkString , updatePosString , (/=\) , (!=!) , abcRow , EC (..) , posErr , posErr' , utok , utoks , ulabel , ueof , etok , etoks , elabel , eeof , cstm ) where import Control.Monad.Reader import Control.Monad.Trans.Identity import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe, maybeToList) import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L import qualified Control.Monad.Writer.Strict as S import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import Test.QuickCheck import Test.HUnit (Assertion, (@?=)) import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>), (<*)) #endif -- | @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 -- ^ Parser to test -> Either (ParseError Char Dec) a -- ^ Expected result of parsing -> String -- ^ Input for the parser -> Property -- ^ Resulting property checkParser p r s = simpleParse p s === r -- | A variant of 'checkParser' that runs given parser code with all -- standard instances of 'MonadParsec'. Useful when testing primitive -- combinators. checkParser' :: (Eq a, Show a) => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test -> Either (ParseError Char Dec) a -- ^ Expected result of parsing -> String -- ^ Input for the parser -> Property -- ^ Resulting property checkParser' p r s = conjoin [ checkParser p r s , checkParser (runIdentityT p) r s , checkParser (runReaderT p ()) r s , checkParser (L.evalStateT p ()) r s , checkParser (S.evalStateT p ()) r s , checkParser (evalWriterTL p) r s , checkParser (evalWriterTS p) r s ] -- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead. checkCase :: (Eq a, Show a) => Parser a -- ^ Parser to test -> Either (ParseError Char Dec) a -- ^ Expected result of parsing -> String -- ^ Input for the parser -> Assertion -- ^ Resulting assertion checkCase p r s = simpleParse p s @?= r -- | Similar to 'checkParser'', but produces HUnit's 'Assertion's instead. checkCase' :: (Eq a, Show a) => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test -> Either (ParseError Char Dec) a -- ^ Expected result of parsing -> String -- ^ Input for the parser -> Assertion -- ^ Resulting assertion checkCase' p r s = do parse p "" s @?= r parse (runIdentityT p) "" s @?= r parse (runReaderT p ()) "" s @?= r parse (L.evalStateT p ()) "" s @?= r parse (S.evalStateT p ()) "" s @?= r parse (evalWriterTL p) "" s @?= r parse (evalWriterTS p) "" s @?= r evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a evalWriterTL = liftM fst . L.runWriterT evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a evalWriterTS = liftM fst . S.runWriterT -- | @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 Char Dec) 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 -- ^ Parser to run -> (Char -> Bool) -- ^ Predicate to test parsed char -> Maybe (ErrorItem Char) -- ^ Representation to use in error messages -> String -- ^ Input stream -> Property -- ^ Resulting property checkChar p f rep' s = checkParser p r s where h = head s rep = Expected <$> maybeToList rep' r | null s = posErr 0 s (ueof : rep) | length s == 1 && f h = Right h | not (f h) = posErr 0 s (utok h : rep) | otherwise = posErr 1 s [utok (s !! 1), eeof] -- | @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 -- ^ Parser to run -> String -- ^ Expected result -> (Char -> Char -> Bool) -- ^ Function used to compare tokens -> String -- ^ Input stream -> Property checkString p a' test s' = checkParser p (w a' 0 s') s' where w [] _ [] = Right s' w [] i (s:_) = posErr i s' [utok s, eeof] w _ 0 [] = posErr 0 s' [ueof, etoks a'] w _ i [] = posErr 0 s' [utoks (take i s'), etoks a'] w (a:as) i (s:ss) | test a s = w as i' ss | otherwise = posErr 0 s' [utoks (take i' s'), etoks a'] where i' = succ i -- | A helper function that is used to advance 'SourcePos' given a 'String'. updatePosString :: Pos -- ^ Tab width -> SourcePos -- ^ Initial position -> String -- ^ 'String' — collection of tokens to process -> SourcePos -- ^ Final position updatePosString w = foldl' f where f p t = snd (defaultUpdatePos w p t) infix 4 /=\ -- preserve whitespace on automatic trim -- | @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 infix 4 !=! -- | @n !=! m@ represents property that holds when results of running @n@ -- and @m@ parsers are identical. This is useful when checking monad laws -- for example. (!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property n !=! m = simpleParse n "" === simpleParse m "" -- | @abcRow a b c@ generates string consisting of character “a” repeated -- @a@ times, character “b” repeated @b@ times, and finally character “c” -- repeated @c@ times. abcRow :: Enum a => a -> a -> a -> String abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c' where f x = replicate (fromEnum x) -- | A component of parse error, useful for fast and dirty construction of -- parse errors with 'posErr' and other helpers. data EC = Unexpected (ErrorItem Char) | Expected (ErrorItem Char) | Custom Dec instance Arbitrary a => Arbitrary (NonEmpty a) where arbitrary = NE.fromList . getNonEmpty <$> arbitrary instance Arbitrary t => Arbitrary (ErrorItem t) where arbitrary = oneof [ Tokens <$> arbitrary , Label <$> arbitrary , return EndOfInput ] instance Arbitrary Pos where arbitrary = unsafePos . getPositive <$> arbitrary instance Arbitrary SourcePos where arbitrary = SourcePos <$> shortString <*> (unsafePos <$> choose (1, 1000)) <*> (unsafePos <$> choose (1, 100)) instance Arbitrary Dec where arbitrary = oneof [ DecFail <$> shortString , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] instance (Arbitrary t, Ord t, Arbitrary e, Ord e) => Arbitrary (ParseError t e) where arbitrary = ParseError <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shortString :: Gen String shortString = sized $ \n -> do k <- choose (0, n `div` 2) vectorOf k arbitrary -- | @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 -- 'utok', 'utoks', 'ulabel', 'ueof', 'etok', 'etoks', 'elabel', and 'eeof' -- for easy ways to create error messages. posErr :: Int -- ^ How many tokens to drop from beginning of steam -> String -- ^ The input stream (just a 'String' here) -> [EC] -- ^ Collection of error components -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left' posErr i s = posErr' (pos :| []) where pos = updatePosString defaultTabWidth (initialPos "") (take i s) -- | The same as 'posErr', but 'SourcePos' should be provided directly. posErr' :: NonEmpty SourcePos -- ^ Position of the error -> [EC] -- ^ Collection of error components -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left' posErr' pos ecs = Left ParseError { errorPos = pos , errorUnexpected = E.fromList (mapMaybe getUnexpected ecs) , errorExpected = E.fromList (mapMaybe getExpected ecs) , errorCustom = E.fromList (mapMaybe getCustom ecs) } where getUnexpected (Unexpected x) = Just x getUnexpected _ = Nothing getExpected (Expected x) = Just x getExpected _ = Nothing getCustom (Custom x) = Just x getCustom _ = Nothing -- | Construct “unexpected token” error component. utok :: Char -> EC utok = Unexpected . Tokens . nes -- | Construct “unexpected steam” error component. This function respects -- some conventions described in 'canonicalizeStream'. utoks :: String -> EC utoks = Unexpected . canonicalizeStream -- | Construct “unexpected label” error component. Do not use with empty -- strings. ulabel :: String -> EC ulabel = Unexpected . Label . NE.fromList -- | Construct “unexpected end of input” error component. ueof :: EC ueof = Unexpected EndOfInput -- | Construct “expecting token” error component. etok :: Char -> EC etok = Expected . Tokens . nes -- | Construct “expecting stream” error component. This function respects -- some conventions described in 'canonicalizeStream'. etoks :: String -> EC etoks = Expected . canonicalizeStream -- | Construct “expecting label” error component. Do not use with empty -- strings. elabel :: String -> EC elabel = Expected . Label . NE.fromList -- | Construct “expecting end of input” component. eeof :: EC eeof = Expected EndOfInput -- | Construct error component consisting of custom data. cstm :: Dec -> EC cstm = Custom -- | Construct appropriate 'MessageItem' representation for given token -- stream. Empty string produces 'EndOfInput', single token — a 'Token', and -- in other cases the 'TokenStream' constructor is used. canonicalizeStream :: String -> ErrorItem Char canonicalizeStream stream = case NE.nonEmpty stream of Nothing -> EndOfInput Just xs -> Tokens xs -- | Make a singleton non-empty list from a value. nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} megaparsec-5.0.1/old-tests/Main.hs0000644000000000000000000000014412710173312015144 0ustar0000000000000000import Test.Framework import Bugs (bugs) main :: IO () main = defaultMain [testGroup "Bugs" bugs] megaparsec-5.0.1/old-tests/Bugs.hs0000644000000000000000000000050612710173312015162 0ustar0000000000000000module 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 ] megaparsec-5.0.1/old-tests/Bugs/Bug2.hs0000644000000000000000000000143512710173312015763 0ustar0000000000000000module 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 megaparsec-5.0.1/old-tests/Bugs/Bug6.hs0000644000000000000000000000076312710173312015772 0ustar0000000000000000module 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 megaparsec-5.0.1/old-tests/Bugs/Bug9.hs0000644000000000000000000000222412710173312015767 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<$)) #endif 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 = L.symbol sc parseTopLevel :: Parser Expr parseTopLevel = parseExpr <* eof parseExpr :: Parser Expr parseExpr = makeExprParser (Const <$> integer) table where table = [[ InfixL (Op <$ operator ">>>") ]] megaparsec-5.0.1/old-tests/Bugs/Bug35.hs0000644000000000000000000000162712710173312016054 0ustar0000000000000000module Bugs.Bug35 (main) where 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) 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 :: Parser Double) "" x @?= Right (read x :: Double) main :: Test main = testCase "Output of Text.Megaparsec.Lexer.float (#35)" testBatch megaparsec-5.0.1/old-tests/Bugs/Bug39.hs0000644000000000000000000000251712710173312016057 0ustar0000000000000000{-# LANGUAGE CPP #-} module Bugs.Bug39 (main) where import Control.Applicative (empty) import Control.Monad (void) #if MIN_VERSION_base(4,7,0) import Data.Either (isLeft, isRight) #endif 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) #if !MIN_VERSION_base(4,7,0) isRight, isLeft :: Either a b -> Bool isRight (Right _) = True isRight _ = False isLeft (Left _ ) = True isLeft _ = False #endif 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 megaparsec-5.0.1/old-tests/Util.hs0000644000000000000000000000047312710173312015202 0ustar0000000000000000module 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 $ parseErrorPretty err Right _ -> [] megaparsec-5.0.1/benchmarks/Main.hs0000644000000000000000000001410512721017320015343 0ustar0000000000000000-- -- Criterion benchmarks for Megaparsec. -- -- Copyright © 2015–2016 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-5.0.1/LICENSE.md0000644000000000000000000000252112644200510013410 0ustar0000000000000000Copyright © 2015–2016 Megaparsec contributors
Copyright © 2007 Paolo Martini
Copyright © 1999–2000 Daan Leijen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. megaparsec-5.0.1/Setup.hs0000644000000000000000000000012712605000660013441 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain megaparsec-5.0.1/megaparsec.cabal0000644000000000000000000001526112740723446015123 0ustar0000000000000000-- -- Cabal config for Megaparsec. -- -- Copyright © 2015–2016 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: 5.0.1 cabal-version: >= 1.10 license: BSD2 license-file: LICENSE.md author: Megaparsec contributors, Paolo Martini , Daan Leijen maintainer: Mark Karpov homepage: https://github.com/mrkkrp/megaparsec bug-reports: https://github.com/mrkkrp/megaparsec/issues category: Parsing synopsis: Monadic parser combinators build-type: Simple description: This is industrial-strength monadic parser combinator library. Megaparsec is a fork of Parsec library originally written by Daan Leijen. extra-source-files: AUTHORS.md , CHANGELOG.md , README.md flag dev description: Turn on development settings. manual: True default: False library build-depends: base >= 4.6 && < 5.0 , bytestring >= 0.2 && < 0.11 , containers >= 0.5 && < 0.6 , deepseq >= 1.3 && < 1.5 , exceptions >= 0.6 && < 0.9 , mtl >= 2.0 && < 3.0 , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6 if !impl(ghc >= 8.0) -- packages providing modules that moved into base-4.9.0.0 build-depends: fail == 4.9.* , semigroups == 0.18.* if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* 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.String , Text.Megaparsec.Text , Text.Megaparsec.Text.Lazy if flag(dev) ghc-options: -Wall -Werror if impl(ghc >= 8.0) ghc-options: -Wcompat ghc-options: -Wnoncanonical-monadfail-instances ghc-options: -Wnoncanonical-monoid-instances else 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 if flag(dev) ghc-options: -Wall -Werror else ghc-options: -O2 -Wall other-modules: Bugs , Bugs.Bug2 , Bugs.Bug6 , Bugs.Bug9 , Bugs.Bug35 , Bugs.Bug39 , Util build-depends: base >= 4.6 && < 5.0 , HUnit >= 1.2 && < 1.4 , megaparsec >= 5.0.1 , test-framework >= 0.6 && < 1.0 , test-framework-hunit >= 0.2 && < 0.4 default-language: Haskell2010 test-suite tests main-is: Main.hs hs-source-dirs: tests type: exitcode-stdio-1.0 if flag(dev) ghc-options: -Wall -Werror else ghc-options: -O2 -Wall other-modules: Char , Combinator , Error , Expr , Lexer , Perm , Pos , Prim , Util build-depends: base >= 4.6 && < 5.0 , HUnit >= 1.2 && < 1.4 , QuickCheck >= 2.8.2 && < 3.0 , bytestring >= 0.2 && < 0.11 , containers >= 0.5 && < 0.6 , exceptions >= 0.6 && < 0.9 , megaparsec >= 5.0.1 , mtl >= 2.0 && < 3.0 , scientific >= 0.3.1 && < 0.4 , test-framework >= 0.6 && < 1.0 , test-framework-hunit >= 0.3 && < 0.4 , test-framework-quickcheck2 >= 0.3 && < 0.4 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6 if !impl(ghc >= 8.0) -- packages providing modules that moved into base-4.9.0.0 build-depends: semigroups == 0.18.* if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* default-language: Haskell2010 benchmark benchmarks main-is: Main.hs hs-source-dirs: benchmarks type: exitcode-stdio-1.0 if flag(dev) ghc-options: -O2 -Wall -Werror else ghc-options: -O2 -Wall build-depends: base >= 4.6 && < 5.0 , bytestring >= 0.10 && < 0.11 , criterion >= 0.6.2.1 && < 1.2 , megaparsec >= 5.0.1 , text >= 0.2 && < 1.3 default-language: Haskell2010 source-repository head type: git location: https://github.com/mrkkrp/megaparsec.git megaparsec-5.0.1/AUTHORS.md0000644000000000000000000000167412644200606013471 0ustar0000000000000000# 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 * Benjamin Kästner * Björn Buckwalter * Bryan O'Sullivan * Cies Breijs * Daniel Díaz * Daniel Gorín * Dennis Gosnell * Derek Elkins * Emil Sköldberg * Herbert Valerio Riedel * Joel Williamson * Mark Karpov * Paolo Martini * redneb * Reto Kramer * Rogan Creswick * Roman Cheplyaka * Ryan Scott * Simon Vandel * Slava Shklyaev * Tal Walter megaparsec-5.0.1/CHANGELOG.md0000644000000000000000000004106512740661641013640 0ustar0000000000000000## Megaparsec 5.0.1 * Derived `NFData` instances for `Pos`, `InvalidPosException`, `SourcePos`, `ErrorItem`, `Dec`, `ParseError`, and `State`. * Derived `Data` instance for `ParseError`, `Data` and `Typeable` instances for `SourcePos` and `State`. * Minor documentation improvements. ## Megaparsec 5.0.0 ### General changes * Removed `parseFromFile` and `StorableStream` type-class that was necessary for it. The reason for removal is that reading from file and then parsing its contents is trivial for every instance of `Stream` and this function provides no way to use newer methods for running a parser, such as `runParser'`. So, simply put, it adds little value and was included in 4.x versions for compatibility reasons. * Moved position-advancing function from arguments of `token` and `tokens` functions to `Stream` type class (named `updatePos`). The new function allows to handle custom streams of tokens where every token contains information about its position in stream better (for example when stream of tokens is produced with happy/alex). * Support for include files (stack of positions instead of flat position) added. The new functions `pushPosition` and `popPosition` can be used to move “vertically” in the stack of positions. `getPosition` and `setPosition` still work on top (“current file”) level, but user can get full stack via `getParserState` if necessary. Note that `ParseError` and pretty-printing for it also support the new feature. * Added type function `Token` associated with `Stream` type class. The function returns type of token corresponding to specific token stream. * Type `ParsecT` (and also type synonym `Parsec`) are now parametrized over type of custom component in parse errors. * Parameters of `MonadParsec` type class are: `e` — type of custom component in parse errors, `s` — type of input stream, and `m` — type of underlying monad. * Type of `failure` primitive combinator was changed, now it accepts three arguments: set of unexpected items, set of expected items, and set of custom data. * Type of `token` primitive combinator was changed, now in case of failure a triple-tuple is returned with elements corresponding to arguments of `failure` primitive. The `token` primitive can also be optionally given an argument of token type to use in error messages (as expected item) in case of end of input. * `unexpected` combinator now accepts argument of type `ErrorItem` instead of plain `String`. * General performance improvements and improvements in speed of some combinators, `manyTill` in particular. ### Error messages * The module `Text.Megaparsec.Pos` was completely rewritten. The new module uses `Pos` data type with smart constructors to ensure that things like line and column number can be only positive. `SourcePos` on the other hand does not require smart constructors anymore and its constructors are exported. `Show` and `Read` instances of `SourcePos` are derived and pretty-printing is done with help of `sourcePosPretty` function. * The module `Text.Megaparsec.Error` was completely rewritten. A number of new types and type-classes are introduced: `ErrorItem`, `Dec`, `ErrorComponent`, and `ShowErrorComponent`. `ParseError` does not need smart constructors anymore and its constructor and field selectors are exported. It uses sets (from the `containers` package) instead of sorted lists to enumerate unexpected and expected items. The new definition is also parametrized over token type and custom data type which can be passed around as part of parse error. Default “custom data” component is `Dec`, which see. All in all, we have completely well-typed and extensible error messages now. `Show` and `Read` instances of `ParseError` are derived and pretty-printing is done with help of `parseErrorPretty`. * The module `Text.Megaparsec.ShowToken` was eliminated and type class `ShowToken` was moved to `Text.Megaparsec.Error`. The only method of that class in now named `showTokens` and it works on streams of tokens, where single tokes are represented by `NonEmpty` list with single element. ### Built-in combinators * Combinators `oneOf`, `oneOf'`, `noneOf`, and `noneOf'` now accept any instance of `Foldable`, not only `String`. ### Lexer * Error messages about incorrect indentation levels were greatly improved. Now every such message contains information about desired ordering between “reference” indentation level and actual indentation level as well as values of these levels. The information is stored in `ParseError` in well-typed form and can be pretty-printed when necessary. As part of this improvement, type of `indentGuard` was changed. * `incorrectIndent` combinator is introduced in `Text.Megaparsec.Lexer` module. It allows to fail with detailed information regarding incorrect indentation. * Introduced `scientific` parser that can parse arbitrary big numbers without error or memory overflow. `float` still returns `Double`, but it's defined in terms of `scientific` now. Since `Scientific` type can reliably represent integer values as well as floating point values, `number` now returns `Scientific` instead of `Either Integer Double` (`Integer` or `Double` can be extracted from `Scientific` value anyway). This in turn makes `signed` parser more natural and general, because we do not need ad-hoc `Signed` type class anymore. * Added `skipBlockCommentNested` function that should help parse possibly nested block comments. * Added `lineFold` function that helps parse line folds. ## Megaparsec 4.4.0 * Now state returned on failure is the exact state of parser at the moment when it failed, which makes incremental parsing feature much better and opens possibilities for features like “on-the-fly” recovering from parse errors. * The `count` combinator now works with `Applicative` instances (previously it worked only with instances of `Alternative`). It's now also faster. * `tokens` and parsers built upon it (such as `string` and `string'`) backtrack automatically on failure now, that is, when they fail, they never consume any input. This is done to make their consumption model match how error messages are reported (which becomes an important thing as user gets more control with primitives like `withRecovery`). This means, in particular, that it's no longer necessary to use `try` with `tokens`-based parsers. This new feature *does not* affect performance in any way. * New primitive parser `withRecovery` added. The parser allows to recover from parse errors “on-the-fly” and continue parsing. Once parsing is finished, several parse errors may be reported or ignored altogether. * `eitherP` combinator added. * Removed `Enum` instance of `Message` type. This was Parsec's legacy that we should eliminate now. `Message` does not constitute enumeration, `toEnum` was never properly defined for it. The idea to use `fromEnum` to determine type of `Message` is also ugly, for this purpose new functions `isUnexpected`, `isExpected`, and `isMessage` are defined in `Text.Megaparsec.Error`. * Minor tweak in signature of `MonadParsec` type class. Collection of constraints changed from `Alternative m, Monad m, Stream s t` to `Alternative m, MonadPlus m, Stream s t`. This is done to make it easier to write more abstract code with older GHC where such primitives as `guard` are defined for instances of `MonadPlus`, not `Alternative`. ## Megaparsec 4.3.0 * Canonicalized `Applicative`/`Monad` instances. Thanks to Herbert Valerio Riedel. * Custom messages in `ParseError` are printed each on its own line. * Now accumulated hints are not used with `ParseError` records that have only custom messages in them (created with `Message` constructor, as opposed to `Unexpected` or `Expected`). This strips “expected” line from custom error messages where it's unlikely to be relevant anyway. * Added higher-level combinators for indentation-sensitive grammars: `indentLevel`, `nonIndented`, and `indentBlock`. ## Megaparsec 4.2.0 * Made `newPos` constructor and other functions in `Text.Megaparsec.Pos` smarter. Now it's impossible to create `SourcePos` with non-positive line number or column number. Unfortunately we cannot use `Numeric.Natural` because we need to support older versions of `base`. * `ParseError` is now a monoid. `mergeError` is used as `mappend`. * Added functions `addErrorMessages` and `newErrorMessages` to add several messages to existing error and to construct error with several attached messages respectively. * `parseFromFile` now lives in `Text.Megaparsec.Prim`. Previously we had 5 nearly identical definitions of the function, varying only in type-specific `readFile` function. Now the problem is solved by introduction of `StorableStream` type class. All supported stream types are instances of the class out of box and thus we have polymorphic version of `parseFromFile`. * `ParseError` is now instance of `Exception` (and `Typeable`). * Introduced `runParser'` and `runParserT'` functions that take and return parser state. This makes it possible to partially parse input, resume parsing, specify non-standard initial textual position, etc. * Introduced `failure` function that allows to fail with arbitrary collection of messages. `unexpected` is now defined in terms of `failure`. One consequence of this design decision is that `failure` is now method of `MonadParsec`, while `unexpected` is not. * Removed deprecated combinators from `Text.Megaparsec.Combinator`: * `chainl` * `chainl1` * `chainr` * `chainr1` * `number` parser in `Text.Megaparsec.Lexer` now can be used with `signed` combinator to parse either signed `Integer` or signed `Double`. ## Megaparsec 4.1.1 * Fixed bug in implementation of `sepEndBy` and `sepEndBy1` and removed deprecation notes for these functions. * Added tests for `sepEndBy` and `sepEndBy1`. ## Megaparsec 4.1.0 * Relaxed dependency on `base`, so that minimal required version of `base` is now 4.6.0.0. This allows Megaparsec to compile with GHC 7.6.x. * `Text.Megaparsec` and `Text.Megaparsec.Prim` do not export data types `Consumed` and `Reply` anymore because they are rather low-level implementation details that should not be visible to end-user. * Representation of file name and textual position in error messages was made conventional. * Fixed some typos is documentation and other materials. ## 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 strings 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. megaparsec-5.0.1/README.md0000644000000000000000000003502412715655564013315 0ustar0000000000000000# Megaparsec [![License FreeBSD](https://img.shields.io/badge/license-FreeBSD-brightgreen.svg)](http://opensource.org/licenses/BSD-2-Clause) [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec) [![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) [![Coverage Status](https://coveralls.io/repos/mrkkrp/megaparsec/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/megaparsec?branch=master) * [Features](#features) * [Core features](#core-features) * [Error messages](#error-messages) * [Alex and Happy support](#alex-and-happy-support) * [Character parsing](#character-parsing) * [Permutation parsing](#permutation-parsing) * [Expression parsing](#expression-parsing) * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials) * [Performance](#performance) * [Comparison with other solutions](#comparison-with-other-solutions) * [Megaparsec and Attoparsec](#megaparsec-and-attoparsec) * [Megaparsec and Parsec](#megaparsec-and-parsec) * [Megaparsec and Parsers](#megaparsec-and-parsers) * [Related packages](#related-packages) * [Authors](#authors) * [Contribution](#contribution) * [License](#license) This is an industrial-strength monadic parser combinator library. Megaparsec is a fork of [Parsec](https://github.com/aslatter/parsec) library originally written by Daan Leijen. ## Features This project provides flexible solutions to satisfy common parsing needs. The section describes them shortly. If you're looking for comprehensive documentation, see the [section about documentation](#documentation). ### Core features The package is built around `MonadParsec`, a MTL-style monad transformer. All tools and features work with any instance of `MonadParsec`. You can achieve various effects combining monad transformers, i.e. building monad stack. Since most common monad transformers like `WriterT`, `StateT`, `ReaderT` and others are instances of `MonadParsec`, you can wrap `ParsecT` *in* these monads, achieving, for example, backtracking state. On the other hand `ParsecT` is instance of many type classes as well. The most useful ones are `Monad`, `Applicative`, `Alternative`, and `MonadParsec`. The module [`Text.Megaparsec.Combinator`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Combinator.html) (its functions are included in `Text.Megaparsec`) contains traditional, general combinators that work with any instance of `Alternative` and some even with instances of `Applicative`. Role of `Monad`, `Applicative`, and `Alternative` should be obvious, so let's enumerate methods of `MonadParsec` type class. The class represents core, basic functions of Megaparsec parsing. The rest of library is built via combination of these primitives: * `failure` allows to fail with arbitrary collection of messages. * `label` allows to add a “label” to any parser, so when it fails the user will see the label in the error message where “expected” items are enumerated. * `hidden` hides any parser from error messages altogether, this is officially recommended way to hide things, prefer it to the `label ""` approach. * `try` enables backtracking in parsing. * `lookAhead` allows to parse something without consuming input. * `notFollowedBy` succeeds when its argument fails, it does not consume input. * `withRecovery` allows to recover from parse errors “on-the-fly” and continue parsing. Once parsing is finished, several parse errors may be reported or ignored altogether. * `eof` only succeeds at the end of input. * `token` is used to parse single token. * `tokens` makes it easy to parse several tokens in a row. * `getParserState` returns full parser state. * `updateParserState` applies given function on parser state. This list of core functions is longer than in some other libraries. Our goal was efficient and readable implementation of functionality provided by every such primitive, not minimal number of them. You can read the comprehensive description of every primitive function in [Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html). Megaparsec can currently work with the following types of input stream: * `String` = `[Char]` * `ByteString` (strict and lazy) * `Text` (strict and lazy) ### Error messages Megaparsec 5 introduces well-typed error messages and ability to use custom data types to adjust the library to your domain of interest. No need to keep your info as shapeless bunch of strings anymore. The default error component (`Dec`) has constructors corresponding to `fail` function and indentation-related error messages. It is a decent option that should work out-of-box for most parsing needs, while you are free to use your own custom error component when necessary with little effort. This new design allowed Megaparsec 5 to have much more helpful error messages for indentation-sensitive parsing instead of plain “incorrect indentation” phrase. ### Alex and Happy support Megaparsec works well with streams of tokens produced by tools like Alex/Happy. Megaparsec 5 adds `updatePos` method to `Stream` type class that gives you full control over textual positions that are used to report token positions in error messages. You can update current position on per character basis or extract it from token — all cases are covered. ### Character parsing Megaparsec has decent support for Unicode-aware character parsing. Functions for character parsing live in [`Text.Megaparsec.Char`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char.html) (they all are included in `Text.Megaparsec`). The functions can be divided into several categories: * *Simple parsers* — parsers that parse certain character or several characters of the same kind. This includes `newline`, `crlf`, `eol`, `tab`, and `space`. * *Parsers corresponding to categories of characters* parse single character that belongs to certain category of characters, for example: `controlChar`, `spaceChar`, `upperChar`, `lowerChar`, `printChar`, `digitChar`, and others. * *General parsers* that allow you to parse a single character you specify or one of given characters, or any character except for given ones, or character satisfying given predicate. Case-insensitive versions of the parsers are available. * *Parsers for sequences of characters* parse strings. These are more efficient and provide better error messages than other approaches most programmers can come up with. Case-sensitive `string` parser is available as well as case-insensitive `string'`. ### Permutation parsing For those who are interested in parsing of permutation phrases, there is [`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html). You have to import the module explicitly, it's not included in the `Text.Megaparsec` module. ### Expression parsing Megaparsec has a solution for parsing of expressions. Take a look at [`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html). You have to import the module explicitly, it's not included in the `Text.Megaparsec`. Given a table of operators that describes their fixity and precedence, you can construct a parser that will parse any expression involving the operators. See documentation for comprehensive description of how it works. ### Lexer [`Text.Megaparsec.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Lexer.html) is a module that should help you write your lexer. If you have used `Parsec` in the past, this module “fixes” its particularly inflexible `Text.Parsec.Token`. `Text.Megaparsec.Lexer` is intended to be imported qualified, it's not included in `Text.Megaparsec`. The module doesn't impose how you should write your parser, but certain approaches may be more elegant than others. An especially important theme is parsing of white space, comments, and indentation. The design of the module allows you quickly solve simple tasks and doesn't get in your way when you want to implement something less standard. Since Megaparsec 5, all tools for indentation-sensitive parsing are available in `Text.Megaparsec.Lexer` module — no third party packages required. ## Documentation Megaparsec is well-documented. All functions and data-types are thoroughly described. We pay attention to avoid outdated info or unclear phrases in our documentation. See the [current version of Megaparsec documentation on Hackage](https://hackage.haskell.org/package/megaparsec) for yourself. ## Tutorials You can visit [site of the project](https://mrkkrp.github.io/megaparsec/) which has [several tutorials](https://mrkkrp.github.io/megaparsec/tutorials.html) that should help you to start with your parsing tasks. The site also has instructions and tips for Parsec users who decide to switch. ## Performance Despite being quite flexible, Megaparsec is also faster than Parsec. The repository includes benchmarks that can be easily used to compare Megaparsec and Parsec. In most cases Megaparsec is faster, sometimes dramatically faster. If you happen to have some other benchmarks, I would appreciate if you add Megaparsec to them and let me know how it performs. ## Comparison with other solutions There are quite a few libraries that can be used for parsing in Haskell, let's compare Megaparsec with some of them. ### Megaparsec and Attoparsec [Attoparsec](https://github.com/bos/attoparsec) is another prominent Haskell library for parsing. Although the both libraries deal with parsing, it's usually easy to decide which you will need in particular project: * *Attoparsec* is much faster but not that feature-rich. It should be used when you want to process large amounts of data where performance matters more than quality of error messages. * *Megaparsec* is good for parsing of source code or other human-readable texts. It has better error messages and it's implemented as monad transformer. So, if you work with something human-readable where size of input data is usually not huge, just go with Megaparsec, otherwise Attoparsec may be a better choice. ### Megaparsec and Parsec Since Megaparsec is a fork of Parsec, it's necessary to list main differences between the two libraries: * Better error messages. We test our error messages using dense QuickCheck tests. Good error messages are just as important for us as correct return values of our parsers. Megaparsec will be especially useful if you write compiler or interpreter for some language. * Some quirks and “buggy features” (as well as plain bugs) of original Parsec are fixed. There is no undocumented surprising stuff in Megaparsec. * Better support for Unicode parsing in `Text.Megaparsec.Char`. * Megaparsec has more powerful combinators and can parse languages where indentation matters. * Comprehensive QuickCheck test suite covering nearly 100% of our code. * We have benchmarks to detect performance regressions. * Better documentation, with 100% of functions covered, without typos and obsolete information, with working examples. Megaparsec's documentation is well-structured and doesn't contain things useless to end users. * Megaparsec's code is clearer and doesn't contain “magic” found in original Parsec. * Megaparsec has well-typed error messages and custom error messages. * Megaparsec can recover from parse errors “on the fly” and continue parsing. * Megaparsec is faster. If you want to see a detailed change log, `CHANGELOG.md` may be helpful. To be honest Parsec's development has seemingly stagnated. It has no test suite (only three per-bug tests), and all its releases beginning from version 3.1.2 (according or its change log) were about introducing and fixing regressions. Parsec is old and somewhat famous in Haskell community, so we understand there will be some kind of inertia, but we advise you use Megaparsec from now on because it solves many problems of original Parsec project. If you think you still have a reason to use original Parsec, open an issue. ### Megaparsec and Parsers There is [Parsers](https://hackage.haskell.org/package/parsers) package, which is great. You can use it with Megaparsec or Parsec, but consider the following: * It depends on *both* Attoparsec and Parsec, which means you always grab useless code installing it. This is ridiculous, by the way, because this package is supposed to be useful for parser builders, so they can write basic core functionality and get the rest “for free”. But with these useful functions you get two more parsers as dependencies. * It currently has a bug in definition of `lookAhead` for various monad transformers like `StateT`, etc. which is visible when you create backtracking state via monad stack, not via built-in features. We intended to use Parsers library in Megaparsec at some point, but aside from already mentioned flaws the library has different conventions for naming of things, different set of “core” functions, etc., different approach to lexer. So it didn't happen, Megaparsec has minimal dependencies, it is feature-rich and self-contained. ## Related packages The following packages are designed to be used with Megaparsec: * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec) — utilities for testing Megaparsec parsers with with [Hspec](https://hackage.haskell.org/package/hspec). ## Authors The project was started and is currently maintained by Mark Karpov. You can find complete list of contributors in `AUTHORS.md` file in official repository of the project. Thanks to all the people who propose features and ideas, although they are not in `AUTHORS.md`, without them Megaparsec would not be that good. ## Contribution Issues (bugs, feature requests or otherwise feedback) may be reported in [the GitHub issue tracker for this project](https://github.com/mrkkrp/megaparsec/issues). Pull requests are also welcome (and yes, they will get attention and will be merged quickly if they are good, we are progressive folks). If you want to write a tutorial to be hosted on Megaparsec's site, open an issue or pull request [here](https://github.com/mrkkrp/megaparsec-site). ## License Copyright © 2015–2016 Megaparsec contributors
Copyright © 2007 Paolo Martini
Copyright © 1999–2000 Daan Leijen Distributed under FreeBSD license.