megaparsec-5.3.1/Text/0000755000000000000000000000000013123732303012736 5ustar0000000000000000megaparsec-5.3.1/Text/Megaparsec/0000755000000000000000000000000013123733004015004 5ustar0000000000000000megaparsec-5.3.1/Text/Megaparsec/ByteString/0000755000000000000000000000000013123732303017077 5ustar0000000000000000megaparsec-5.3.1/Text/Megaparsec/Text/0000755000000000000000000000000013123732303015731 5ustar0000000000000000megaparsec-5.3.1/bench-memory/0000755000000000000000000000000013123732303014377 5ustar0000000000000000megaparsec-5.3.1/bench-speed/0000755000000000000000000000000013123732303014167 5ustar0000000000000000megaparsec-5.3.1/tests/0000755000000000000000000000000013123732303013154 5ustar0000000000000000megaparsec-5.3.1/tests/Test/0000755000000000000000000000000013116223306014073 5ustar0000000000000000megaparsec-5.3.1/tests/Test/Hspec/0000755000000000000000000000000013124111712015131 5ustar0000000000000000megaparsec-5.3.1/tests/Test/Hspec/Megaparsec/0000755000000000000000000000000013123732303017204 5ustar0000000000000000megaparsec-5.3.1/tests/Text/0000755000000000000000000000000013123732303014100 5ustar0000000000000000megaparsec-5.3.1/tests/Text/Megaparsec/0000755000000000000000000000000013124146523016153 5ustar0000000000000000megaparsec-5.3.1/Text/Megaparsec.hs0000644000000000000000000001277513123732303015355 0ustar0000000000000000-- | -- Module : Text.Megaparsec -- Copyright : © 2015–2017 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 the tutorials . -- -- By default this module is set up to parse character data. If you'd like -- to parse the result of your own tokenizer you should start with the -- following imports: -- -- > import Text.Megaparsec.Prim -- > import Text.Megaparsec.Combinator -- -- Then you can implement your own version of 'satisfy' on top of the -- 'token' primitive, etc. -- -- The typical import section looks like this: -- -- > import Text.Megaparsec -- > import Text.Megaparsec.String -- > -- import Text.Megaparsec.ByteString -- > -- import Text.Megaparsec.ByteString.Lazy -- > -- import Text.Megaparsec.Text -- > -- import Text.Megaparsec.Text.Lazy -- -- As you can see the second import depends on the data type you want to use -- as input stream. It just defines the useful type-synonym @Parser@. -- -- Megaparsec 5 uses some type-level machinery to provide flexibility -- without compromising on type safety. Thus type signatures are sometimes -- necessary to avoid ambiguous types. If you're seeing a error message that -- reads like “Ambiguous type variable @e0@ arising from … prevents the -- constraint @(ErrorComponent e0)@ from being resolved”, you need to give -- an explicit signature to your parser to resolve the ambiguity. It's a -- good idea to provide type signatures for all top-level definitions. -- -- Megaparsec is capable of a lot. Apart from this standard functionality -- you can parse permutation phrases with "Text.Megaparsec.Perm", -- expressions with "Text.Megaparsec.Expr", and even entire languages with -- "Text.Megaparsec.Lexer". These modules should be imported explicitly -- along with the two modules mentioned above. module Text.Megaparsec ( -- * Running parser Parsec , ParsecT , parse , parseMaybe , parseTest , runParser , runParser' , runParserT , runParserT' -- * Combinators , (A.<|>) -- $assocbo , A.many -- $many , A.some -- $some , A.optional -- $optional , unexpected , match , region , failure , () , label , hidden , try , lookAhead , notFollowedBy , withRecovery , observing , eof , token , tokens , between , choice , count , count' , eitherP , endBy , endBy1 , manyTill , someTill , option , sepBy , sepBy1 , sepEndBy , sepEndBy1 , skipMany , skipSome -- * Character parsing , newline , crlf , eol , tab , space , controlChar , spaceChar , upperChar , lowerChar , letterChar , alphaNumChar , printChar , digitChar , octDigitChar , hexDigitChar , markChar , numberChar , punctuationChar , symbolChar , separatorChar , asciiChar , latin1Char , charCategory , char , char' , anyChar , oneOf , oneOf' , noneOf , noneOf' , satisfy , string , string' -- * Textual source position , Pos , mkPos , unPos , unsafePos , InvalidPosException (..) , SourcePos (..) , initialPos , sourcePosPretty -- * Error messages , ErrorItem (..) , ErrorComponent (..) , Dec (..) , ParseError (..) , ShowToken (..) , ShowErrorComponent (..) , parseErrorPretty -- * Debugging , dbg -- * Low-level operations , Stream (..) , State (..) , getInput , setInput , getPosition , getNextTokenPosition , setPosition , pushPosition , popPosition , getTokensProcessed , setTokensProcessed , getTabWidth , setTabWidth , getParserState , setParserState , updateParserState ) where import qualified Control.Applicative as A import Text.Megaparsec.Char import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim -- $assocbo -- -- This combinator implements choice. The parser @p \<|> q@ first applies -- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails -- /without consuming any input/, parser @q@ is tried. -- -- The parser is called /predictive/ since @q@ is only tried when parser @p@ -- didn't consume any input (i.e. the look ahead is 1). This -- non-backtracking behaviour allows for both an efficient implementation of -- the parser combinators and the generation of good error messages. -- $many -- -- @many p@ applies the parser @p@ /zero/ or more times and returns a list -- of the returned values of @p@. Note that if the @p@ parser fails -- consuming input, then the entire @many p@ parser fails with the error -- message @p@ produced instead of just stopping iterating. In these cases -- wrapping @p@ with 'try' may be desirable. -- -- > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_') -- $some -- -- @some p@ applies the parser @p@ /one/ or more times and returns a list of -- the returned values of @p@. The note about behavior of the combinator in -- the case when @p@ fails consuming input (see 'A.many') applies to 'some' -- as well. -- -- > word = some letter -- $optional -- -- @optional p@ tries to apply the parser @p@. It will parse @p@ or nothing. -- It only fails if @p@ fails after consuming input. On success result of -- @p@ is returned inside of 'Just', on failure 'Nothing' is returned. megaparsec-5.3.1/Text/Megaparsec/ByteString.hs0000644000000000000000000000132713123732303017436 0ustar0000000000000000-- | -- Module : Text.Megaparsec.ByteString -- Copyright : © 2015–2017 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 the user can use it to easily change type of input stream -- by importing different “type modules”. This one is for strict -- 'ByteString's. type Parser = Parsec Dec ByteString megaparsec-5.3.1/Text/Megaparsec/ByteString/Lazy.hs0000644000000000000000000000134613123732303020356 0ustar0000000000000000-- | -- Module : Text.Megaparsec.ByteString.Lazy -- Copyright : © 2015–2017 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 the user can use it to easily change the type of input -- stream by importing different “type modules”. This one is for lazy -- 'ByteString's. type Parser = Parsec Dec ByteString megaparsec-5.3.1/Text/Megaparsec/Char.hs0000644000000000000000000003117713123732303016227 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Char -- Copyright : © 2015–2017 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 Data.Foldable (Foldable (), any, elem, notElem) import Prelude hiding (any, elem, notElem) #endif ---------------------------------------------------------------------------- -- Simple parsers -- | Parse a newline character. newline :: (MonadParsec e s m, Token s ~ Char) => m Char newline = char '\n' {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. crlf :: (MonadParsec e s m, Token s ~ Char) => m String crlf = string "\r\n" {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. -- -- > eol = (pure <$> newline) <|> crlf "end of line" eol :: (MonadParsec e s m, Token s ~ Char) => m String eol = (pure <$> newline) <|> crlf "end of line" {-# INLINE eol #-} -- | Parse a tab character. tab :: (MonadParsec e s m, Token s ~ Char) => m Char tab = char '\t' {-# INLINE tab #-} -- | Skip /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 -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode). controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char controlChar = satisfy isControl "control character" {-# INLINE controlChar #-} -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. spaceChar :: (MonadParsec e s m, Token s ~ Char) => m Char spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} -- | Parse 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 #-} -- | Parse a lower-case alphabetic Unicode character. lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char lowerChar = satisfy isLower "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter. letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char letterChar = satisfy isLetter "letter" {-# INLINE letterChar #-} -- | Parse an alphabetic or numeric digit Unicode characters. -- -- Note that the 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 #-} -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space. printChar :: (MonadParsec e s m, Token s ~ Char) => m Char printChar = satisfy isPrint "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char digitChar = satisfy isDigit "digit" {-# INLINE digitChar #-} -- | Parse an octal digit, i.e. between “0” and “7”. octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char octDigitChar = satisfy isOctDigit "octal digit" {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char hexDigitChar = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters. markChar :: (MonadParsec e s m, Token s ~ Char) => m Char markChar = satisfy isMark "mark character" {-# INLINE markChar #-} -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc. numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char numberChar = satisfy isNumber "numeric character" {-# INLINE numberChar #-} -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes. punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m Char punctuationChar = satisfy isPunctuation "punctuation" {-# INLINE punctuationChar #-} -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols. symbolChar :: (MonadParsec e s m, Token s ~ Char) => m Char symbolChar = satisfy isSymbol "symbol" {-# INLINE symbolChar #-} -- | Parse a Unicode space and separator characters. separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char separatorChar = satisfy isSeparator "separator" {-# INLINE separatorChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. asciiChar :: (MonadParsec e s m, Token s ~ Char) => m Char asciiChar = satisfy isAscii "ASCII character" {-# INLINE asciiChar #-} -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. latin1Char :: (MonadParsec e s m, Token s ~ Char) => m Char latin1Char = 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 #-} -- | Return the human-readable name of Unicode General Category. categoryName :: GeneralCategory -> String categoryName cat = fromJust $ lookup cat [ (UppercaseLetter , "uppercase letter") , (LowercaseLetter , "lowercase letter") , (TitlecaseLetter , "titlecase letter") , (ModifierLetter , "modifier letter") , (OtherLetter , "other letter") , (NonSpacingMark , "non-spacing mark") , (SpacingCombiningMark, "spacing combining mark") , (EnclosingMark , "enclosing mark") , (DecimalNumber , "decimal number character") , (LetterNumber , "letter number character") , (OtherNumber , "other number character") , (ConnectorPunctuation, "connector punctuation") , (DashPunctuation , "dash punctuation") , (OpenPunctuation , "open punctuation") , (ClosePunctuation , "close punctuation") , (InitialQuote , "initial quote") , (FinalQuote , "final quote") , (OtherPunctuation , "other punctuation") , (MathSymbol , "math symbol") , (CurrencySymbol , "currency symbol") , (ModifierSymbol , "modifier symbol") , (OtherSymbol , "other symbol") , (Space , "white space") , (LineSeparator , "line separator") , (ParagraphSeparator , "paragraph separator") , (Control , "control character") , (Format , "format character") , (Surrogate , "surrogate character") , (PrivateUse , "private-use Unicode character") , (NotAssigned , "non-assigned Unicode character") ] ---------------------------------------------------------------------------- -- 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 the -- 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 -- collection of characters @cs@. Returns the parsed character. Note that -- this parser cannot automatically generate the “expected” component of -- error message, so usually you should label it manually with 'label' or -- (''). -- -- 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 = toUpper x == toUpper y {-# INLINE casei #-} -- | Case-insensitive 'elem'. elemi :: Foldable f => Char -> f Char -> Bool elemi = any . casei {-# INLINE elemi #-} -- | Case-insensitive 'notElem'. notElemi :: Foldable f => Char -> f Char -> Bool notElemi c = not . elemi c {-# INLINE notElemi #-} megaparsec-5.3.1/Text/Megaparsec/Combinator.hs0000644000000000000000000001246713123732303017450 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Combinator -- Copyright : © 2015–2017 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 the combinators work -- with 'Applicative' and 'Alternative' instances. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Text.Megaparsec.Combinator ( between , choice , count , count' , eitherP , endBy , endBy1 , manyTill , someTill , option , sepBy , sepBy1 , sepEndBy , sepEndBy1 , skipMany , skipSome ) where import Control.Applicative import Control.Monad (void) import Data.Foldable (asum) #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable) import Data.Traversable (sequenceA) #endif -- | @between open close p@ parses @open@, followed by @p@ and @close@. -- Returns the value returned by @p@. -- -- > braces = between (symbol "{") (symbol "}") between :: Applicative m => m open -> m close -> m a -> m a between open close p = open *> p <* close {-# INLINE between #-} -- | @choice ps@ tries to apply the parsers in the list @ps@ in order, until -- one of them succeeds. Returns the value of the succeeding parser. choice :: (Foldable f, Alternative m) => f (m a) -> m a choice = asum {-# INLINE choice #-} -- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal -- to zero, the parser equals to @return []@. Returns a list of @n@ values. count :: Applicative m => Int -> m a -> m [a] count n p = sequenceA (replicate n p) {-# INLINE count #-} -- | @count' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is not -- positive or @m > n@, the parser equals to @return []@. Returns a list of -- parsed values. -- -- Please note that @m@ /may/ be negative, in this case effect is the same -- as if it were equal to zero. count' :: Alternative m => Int -> Int -> m a -> m [a] count' m' n' p = go m' n' where go !m !n | n <= 0 || m > n = pure [] | m > 0 = (:) <$> p <*> go (m - 1) (n - 1) | otherwise = let f t ts = maybe [] (:ts) t in f <$> optional p <*> go 0 (pred n) {-# INLINE count' #-} -- | Combine two alternatives. -- -- @since 4.4.0 eitherP :: Alternative m => m a -> m b -> m (Either a b) eitherP a b = (Left <$> a) <|> (Right <$> b) {-# INLINE eitherP #-} -- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated and -- ended by @sep@. Returns a list of values returned by @p@. -- -- > cStatements = cStatement `endBy` semicolon endBy :: Alternative m => m a -> m sep -> m [a] endBy p sep = many (p <* sep) {-# INLINE endBy #-} -- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated and -- ended by @sep@. Returns a list of values returned by @p@. endBy1 :: Alternative m => m a -> m sep -> m [a] endBy1 p sep = some (p <* sep) {-# INLINE endBy1 #-} -- | @manyTill p end@ applies parser @p@ /zero/ or more times until parser -- @end@ succeeds. Returns the list of values returned by @p@. This parser -- can be used to scan comments: -- -- > simpleComment = string "") manyTill :: Alternative m => m a -> m end -> m [a] manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) {-# INLINE manyTill #-} -- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should -- succeed at least once. someTill :: Alternative m => m a -> m end -> m [a] someTill p end = (:) <$> p <*> manyTill p end {-# INLINE someTill #-} -- | @option x p@ tries to apply the parser @p@. If @p@ fails without -- consuming input, it returns the value @x@, otherwise the value returned -- by @p@. -- -- > priority = option 0 (digitToInt <$> digitChar) option :: Alternative m => a -> m a -> m a option x p = p <|> pure x {-# INLINE option #-} -- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated by -- @sep@. Returns a list of values returned by @p@. -- -- > commaSep p = p `sepBy` comma sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = sepBy1 p sep <|> pure [] {-# INLINE sepBy #-} -- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated by -- @sep@. Returns a list of values returned by @p@. sepBy1 :: Alternative m => m a -> m sep -> m [a] sepBy1 p sep = (:) <$> p <*> many (sep *> p) {-# INLINE sepBy1 #-} -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, separated -- and optionally ended by @sep@. Returns a list of values returned by @p@. sepEndBy :: Alternative m => m a -> m sep -> m [a] sepEndBy p sep = sepEndBy1 p sep <|> pure [] {-# INLINE sepEndBy #-} -- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, separated -- and optionally ended by @sep@. Returns a list of values returned by @p@. sepEndBy1 :: Alternative m => m a -> m sep -> m [a] sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) -- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping its -- result. -- -- > space = skipMany spaceChar skipMany :: Alternative m => m a -> m () skipMany p = void $ many p {-# INLINE skipMany #-} -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping its -- result. skipSome :: Alternative m => m a -> m () skipSome p = void $ some p {-# INLINE skipSome #-} megaparsec-5.3.1/Text/Megaparsec/Error.hs0000644000000000000000000003022613123732760016444 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Error -- Copyright : © 2015–2017 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 , parseErrorTextPretty ) 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 Test.QuickCheck hiding (label) 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 -- 'ParseError'. The data type is parametrized over the 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) instance Arbitrary t => Arbitrary (ErrorItem t) where arbitrary = oneof [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary) , Label <$> (NE.fromList . getNonEmpty <$> arbitrary) , return EndOfInput ] -- | The type class defines how to represent information about various -- exceptional situations. Data types that are used as custom data component -- in 'ParseError' must be instances of this type class. -- -- @since 5.0.0 class Ord e => ErrorComponent e where -- | Represent the message passed to 'fail' in parser monad. -- -- @since 5.0.0 representFail :: String -> e -- | Represent information about incorrect indentation. -- -- @since 5.0.0 representIndentation :: Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> Pos -- ^ Actual indentation level -> e instance ErrorComponent () where representFail _ = () representIndentation _ _ _ = () -- | “Default error component”. This is our instance of 'ErrorComponent' -- provided out-of-box. -- -- @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 Arbitrary Dec where arbitrary = oneof [ sized (\n -> do k <- choose (0, n `div` 2) DecFail <$> vectorOf k arbitrary) , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] instance ErrorComponent Dec where representFail = DecFail representIndentation = DecIndentation -- | 'ParseError' represents… parse errors. It provides the stack of source -- positions, a set of expected and unexpected tokens as well as a set of -- custom associated data. The data type is parametrized over the token type -- @t@ and the custom data @e@. -- -- Note that the stack of source positions contains current position as its -- head, and the rest of positions allows to track full sequence of include -- files with topmost source file at the end of the list. -- -- 'Semigroup' (and 'Monoid') instance of the data type allows to merge -- parse errors from different branches of parsing. When merging two -- 'ParseError's, the 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 , Ord t , ShowToken t , Show e , Typeable e , ShowErrorComponent e ) => Exception (ParseError t e) where #if MIN_VERSION_base(4,8,0) displayException = parseErrorPretty #endif instance (Arbitrary t, Ord t, Arbitrary e, Ord e) => Arbitrary (ParseError t e) where arbitrary = ParseError <$> (NE.fromList . getNonEmpty <$> arbitrary) #if MIN_VERSION_QuickCheck(2,8,2) <*> arbitrary <*> arbitrary <*> arbitrary #else <*> (E.fromList <$> arbitrary) <*> (E.fromList <$> arbitrary) <*> (E.fromList <$> arbitrary) #endif -- | Merge two error data structures into one joining their collections of -- message items and preferring the longest match. In other words, earlier -- error message is discarded. This may seem counter-intuitive, but -- '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 '\NUL' = "null (control character)" charPretty '\SOH' = "start of heading (control character)" charPretty '\STX' = "start of text (control character)" charPretty '\ETX' = "end of text (control character)" charPretty '\EOT' = "end of transmission (control character)" charPretty '\ENQ' = "enquiry (control character)" charPretty '\ACK' = "acknowledge (control character)" charPretty '\BEL' = "bell (control character)" charPretty '\BS' = "backspace" charPretty '\t' = "tab" charPretty '\n' = "newline" charPretty '\v' = "vertical tab" charPretty '\f' = "form feed (control character)" charPretty '\r' = "carriage return" charPretty '\SO' = "shift out (control character)" charPretty '\SI' = "shift in (control character)" charPretty '\DLE' = "data link escape (control character)" charPretty '\DC1' = "device control one (control character)" charPretty '\DC2' = "device control two (control character)" charPretty '\DC3' = "device control three (control character)" charPretty '\DC4' = "device control four (control character)" charPretty '\NAK' = "negative acknowledge (control character)" charPretty '\SYN' = "synchronous idle (control character)" charPretty '\ETB' = "end of transmission block (control character)" charPretty '\CAN' = "cancel (control character)" charPretty '\EM' = "end of medium (control character)" charPretty '\SUB' = "substitute (control character)" charPretty '\ESC' = "escape (control character)" charPretty '\FS' = "file separator (control character)" charPretty '\GS' = "group separator (control character)" charPretty '\RS' = "record separator (control character)" charPretty '\US' = "unit separator (control character)" charPretty '\DEL' = "delete (control character)" charPretty ' ' = "space" charPretty '\160' = "non-breaking space" charPretty x = "'" ++ [x] ++ "'" -- | 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 a 'ParseError'. The rendered 'String' always ends with a -- newline. -- -- The function is defined as: -- -- > parseErrorPretty e = -- > sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e -- -- @since 5.0.0 parseErrorPretty :: ( Ord t , ShowToken t , ShowErrorComponent e ) => ParseError t e -- ^ Parse error to render -> String -- ^ Result of rendering parseErrorPretty e = sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e -- | Pretty-print a stack of source positions. -- -- @since 5.0.0 sourcePosStackPretty :: NonEmpty SourcePos -> String sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos where (pos :| rest') = ms rest = reverse rest' f p = "in file included from " ++ sourcePosPretty p ++ ",\n" -- | Transforms a 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 the rules of English punctuation. orList :: NonEmpty String -> String orList (x:|[]) = x orList (x:|[y]) = x ++ " or " ++ y orList xs = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs -- | Pretty-print a textual part of a 'ParseError', that is, everything -- except stack of source positions. The rendered staring always ends with a -- new line. -- -- @since 5.1.0 parseErrorTextPretty :: ( Ord t , ShowToken t , ShowErrorComponent e ) => ParseError t e -- ^ Parse error to render -> String -- ^ Result of rendering parseErrorTextPretty (ParseError _ us ps xs) = if E.null us && E.null ps && E.null xs then "unknown parse error\n" else concat [ messageItemsPretty "unexpected " us , messageItemsPretty "expecting " ps , unlines (showErrorComponent <$> E.toAscList xs) ] megaparsec-5.3.1/Text/Megaparsec/Expr.hs0000644000000000000000000001321013123732303016254 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Expr -- Copyright : © 2015–2017 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 the @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 allowing repeating -- prefix or postfix operators is not desirable. -- -- If you want to have an operator that is a prefix of another operator in -- the table, use the following (or similar) wrapper instead of plain -- 'symbol': -- -- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) -- -- @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 the 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 a @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.3.1/Text/Megaparsec/Lexer.hs0000644000000000000000000004436013123732303016427 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Lexer -- Copyright : © 2015–2017 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 MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.Lexer ( -- * White space space , lexeme , symbol , symbol' , skipLineComment , skipBlockComment , skipBlockCommentNested -- * Indentation , indentLevel , incorrectIndent , indentGuard , nonIndented , IndentOpt (..) , indentBlock , lineFold -- * Character and string literals , charLiteral -- * Numbers , integer , decimal , hexadecimal , octal , scientific , float , number , signed ) where import Control.Applicative import Control.Monad (void) import Data.Char (readLitChar) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (listToMaybe, fromMaybe, isJust) import Data.Scientific (Scientific, toRealFloat) import qualified Data.Set as E import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import qualified Text.Megaparsec.Char as C ---------------------------------------------------------------------------- -- White space -- | @space spaceChar lineComment blockComment@ produces parser that can -- parse white space in general. It's expected that you create such a parser -- once and pass it to other functions in this module as needed (when you -- see @spaceConsumer@ in documentation, usually it means that something -- like 'space' is expected there). -- -- @spaceChar@ is used to parse trivial space characters. You can use -- 'C.spaceChar' from "Text.Megaparsec.Char" for this purpose as well as -- your own parser (if you don't want to automatically consume newlines, for -- example). -- -- @lineComment@ is used to parse line comments. You can use -- 'skipLineComment' if you don't need anything special. -- -- @blockComment@ is used to parse block (multi-line) comments. You can use -- 'skipBlockComment' if you don't need anything special. -- -- Parsing of white space is an important part of any parser. We propose a -- convention where every lexeme parser assumes no spaces before the lexeme -- and consumes all spaces after the lexeme; this is what the 'lexeme' -- combinator does, and so it's enough to wrap every lexeme parser with -- 'lexeme' to achieve this. Note that you'll need to call 'space' manually -- to consume any white space before the first lexeme (i.e. at the beginning -- of the file). space :: MonadParsec e s m => m () -- ^ A parser for a space character (e.g. @'void' 'C.spaceChar'@) -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') -> m () space ch line block = hidden . skipMany $ choice [ch, line, block] -- | This is a wrapper for lexemes. Typical usage is to supply the first -- argument (parser that consumes white space, probably defined via 'space') -- and use the resulting function to wrap parsers for every lexeme. -- -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.integer lexeme :: MonadParsec e s m => m () -- ^ How to consume white space after lexeme -> m a -- ^ How to parse actual lexeme -> m a lexeme spc p = p <* spc -- | This is a helper to parse symbols, i.e. verbatim strings. You pass the -- first argument (parser that consumes white space, probably defined via -- 'space') and then you can use the resulting function to parse strings: -- -- > symbol = L.symbol spaceConsumer -- > -- > parens = between (symbol "(") (symbol ")") -- > braces = between (symbol "{") (symbol "}") -- > angles = between (symbol "<") (symbol ">") -- > brackets = between (symbol "[") (symbol "]") -- > semicolon = symbol ";" -- > comma = symbol "," -- > colon = symbol ":" -- > dot = symbol "." symbol :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume white space after lexeme -> String -- ^ String to parse -> m String symbol spc = lexeme spc . C.string -- | Case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages. symbol' :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume white space after lexeme -> String -- ^ String to parse (case-insensitive) -> m String symbol' spc = lexeme spc . C.string' -- | Given comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually. skipLineComment :: (MonadParsec e s m, Token s ~ Char) => String -- ^ Line comment prefix -> m () skipLineComment prefix = p >> void (manyTill C.anyChar n) where p = C.string prefix n = lookAhead (void C.newline) <|> eof -- | @skipBlockComment start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment :: (MonadParsec e s m, Token s ~ Char) => String -- ^ Start of block comment -> String -- ^ End of block comment -> m () skipBlockComment start end = p >> void (manyTill C.anyChar n) where p = C.string start n = C.string end -- | @skipBlockCommentNested start end@ skips possibly nested block comment -- starting with @start@ and ending with @end@. -- -- @since 5.0.0 skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char) => String -- ^ Start of block comment -> String -- ^ End of block comment -> m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void C.anyChar p = C.string start n = C.string end ---------------------------------------------------------------------------- -- Indentation -- | Return the current indentation level. -- -- The function is a simple shortcut defined as: -- -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0 indentLevel :: MonadParsec e s m => m Pos indentLevel = sourceColumn <$> getPosition -- | Fail reporting incorrect indentation error. The error has attached -- information: -- -- * Desired ordering between reference level and actual level -- * Reference indentation level -- * Actual indentation level -- -- @since 5.0.0 incorrectIndent :: MonadParsec e s m => Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> Pos -- ^ Actual indentation level -> m a incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x) where x = representIndentation ord ref actual -- | @indentGuard spaceConsumer ord ref@ first consumes all white space -- (indentation) with @spaceConsumer@ parser, then it checks the column -- position. Ordering between current indentation level and the reference -- indentation level @ref@ should be @ord@, otherwise the parser fails. On -- success the current column position is returned. -- -- When you want to parse a block of indentation, first run this parser with -- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@—this will -- make sure you have some indentation. Use returned value to check -- indentation on every subsequent line according to syntax of your -- language. indentGuard :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> Ordering -- ^ Desired ordering between reference level and actual level -> Pos -- ^ Reference indentation level -> m Pos -- ^ Current column (indentation level) indentGuard sc ord ref = do sc actual <- indentLevel if compare actual ref == ord then return actual else incorrectIndent ord ref actual -- | Parse a non-indented construction. This ensures that there is no -- indentation before actual data. Useful, for example, as a wrapper for -- top-level function definitions. -- -- @since 4.3.0 nonIndented :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> m a -- ^ How to parse actual data -> m a nonIndented sc p = indentGuard sc EQ (unsafePos 1) *> p -- | The data type represents available behaviors for parsing of indented -- tokens. This is used in 'indentBlock', which see. -- -- @since 4.3.0 data IndentOpt m a b = IndentNone a -- ^ Parse no indented tokens, just return the value | IndentMany (Maybe Pos) ([b] -> m a) (m b) -- ^ Parse many indented tokens (possibly zero), use given indentation -- level (if 'Nothing', use level of the first indented token); the -- second argument tells how to get final result, and third argument -- describes how to parse an indented token | IndentSome (Maybe Pos) ([b] -> m a) (m b) -- ^ Just like 'IndentMany', but requires at least one indented token to -- be present -- | Parse a “reference” token and a number of other tokens that have -- greater (but the same) level of indentation than that of “reference” -- token. Reference token can influence parsing, see 'IndentOpt' for more -- information. -- -- Tokens /must not/ consume newlines after them. On the other hand, the -- first argument of this function /must/ consume newlines among other white -- space characters. -- -- @since 4.3.0 indentBlock :: (MonadParsec e s m, Token s ~ Char) => m () -- ^ How to consume indentation (white space) -> m (IndentOpt m a b) -- ^ How to parse “reference” token -> m a indentBlock sc r = do sc ref <- indentLevel a <- r case a of IndentNone x -> sc *> return x IndentMany indent f p -> do mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref) done <- isJust <$> optional eof case (mlvl, done) of (Just lvl, False) -> indentedItems ref (fromMaybe lvl indent) sc p >>= f _ -> sc *> f [] IndentSome indent f p -> do lvl <- C.eol *> indentGuard sc GT ref x <- p xs <- indentedItems ref (fromMaybe lvl indent) sc p f (x:xs) -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of the public API. indentedItems :: MonadParsec e s m => Pos -- ^ Reference indentation level -> Pos -- ^ Level of the first indented item ('lookAhead'ed) -> m () -- ^ How to consume indentation (white space) -> m b -- ^ How to parse indented tokens -> m [b] indentedItems ref lvl sc p = go where go = do sc pos <- indentLevel done <- isJust <$> optional eof if done then return [] else if | pos <= ref -> return [] | pos == lvl -> (:) <$> p <*> go | otherwise -> incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/ -- consume newlines in order to work properly. The second argument is a -- callback that receives a custom space-consuming parser as argument. This -- parser should be used after separate components of line fold that can be -- put on different lines. -- -- An example should clarify the usage pattern: -- -- > sc = L.space (void spaceChar) empty empty -- > -- > myFold = L.lineFold sc $ \sc' -> do -- > L.symbol sc' "foo" -- > L.symbol sc' "bar" -- > L.symbol sc "baz" -- for the last symbol we use normal space consumer -- -- @since 5.0.0 lineFold :: MonadParsec e s m => m () -- ^ How to consume indentation (white space) -> (m () -> m a) -- ^ Callback that uses provided space-consumer -> m a lineFold sc action = sc >> indentLevel >>= action . void . indentGuard sc GT ---------------------------------------------------------------------------- -- Character and string literals -- | The lexeme parser parses a single literal character without quotes. The -- purpose of this parser is to help with parsing of conventional escape -- sequences. It's your responsibility to take care of character literal -- syntax in your language (by surrounding it with single quotes or -- similar). -- -- The literal character is parsed according to the grammar rules defined in -- the Haskell report. -- -- Note that you can use this parser as a building block to parse various -- string literals: -- -- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"') -- -- If you want to write @stringLiteral@ that adheres to the Haskell report -- though, you'll need to take care of the @\\&@ combination which is not a -- character, but can be used to separate characters (as in @\"\\291\\&4\"@ -- which is two characters long): -- -- > stringLiteral = catMaybes <$> (char '"' >> manyTill ch (char '"')) -- > where ch = (Just <$> L.charLiteral) <|> (Nothing <$ string "\\&") charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint, -- and we do know that r will be non-empty if count' succeeds. ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar case listToMaybe (readLitChar r) of Just (c, r') -> count (length r - length r') C.anyChar >> return c Nothing -> unexpected (Tokens (x:|[])) ---------------------------------------------------------------------------- -- Numbers -- | Parse an integer without sign in decimal representation (according to -- the format of integer literals described in the Haskell report). -- -- If you need to parse signed integers, see 'signed' combinator. integer :: (MonadParsec e s m, Token s ~ Char) => m Integer integer = decimal "integer" -- | The same as 'integer', but 'integer' is 'label'ed with “integer” label, -- while this parser is labeled with “decimal integer”. decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer decimal = nump "" C.digitChar "decimal integer" -- | Parse an integer in hexadecimal representation. Representation of -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before -- parsing the number itself. -- -- For example you can make it conform to Haskell report like this: -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer hexadecimal = nump "0x" C.hexDigitChar "hexadecimal integer" -- | Parse an integer in octal representation. Representation of octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing -- the number itself. octal :: (MonadParsec e s m, Token s ~ Char) => m Integer octal = nump "0o" C.octDigitChar "octal integer" -- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then -- prepends @prefix@ to returned value and tries to interpret the result as -- an integer according to Haskell syntax. nump :: MonadParsec e s m => String -> m Char -> m Integer nump prefix baseDigit = read . (prefix ++) <$> some baseDigit -- | Parse a floating point value as a 'Scientific' number. 'Scientific' is -- great for parsing of arbitrary precision numbers coming from an untrusted -- source. See documentation in "Data.Scientific" for more information. -- Representation of the floating point value is expected to be according to -- the Haskell report. -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- -- @since 5.0.0 scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific scientific = label "floating point number" (read <$> f) where f = (++) <$> some C.digitChar <*> (fraction <|> fExp) -- | Parse a floating point number without sign. This is a simple shortcut -- defined as: -- -- > float = toRealFloat <$> scientific float :: (MonadParsec e s m, Token s ~ Char) => m Double float = toRealFloat <$> scientific -- | This is a helper for 'float' parser. It parses fractional part of -- floating point number, that is, dot and everything after it. fraction :: (MonadParsec e s m, Token s ~ Char) => m String fraction = do void (C.char '.') d <- some C.digitChar e <- option "" fExp return ('.' : d ++ e) -- | This helper parses exponent of floating point numbers. fExp :: (MonadParsec e s m, Token s ~ Char) => m String fExp = do expChar <- C.char' 'e' signStr <- option "" (pure <$> choice (C.char <$> "+-")) d <- some C.digitChar return (expChar : signStr ++ d) -- | Parse a number: either integer or floating point. The parser can handle -- overlapping grammars graciously. Use functions like -- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and -- extract integer or real values. number :: (MonadParsec e s m, Token s ~ Char) => m Scientific number = label "number" (read <$> f) where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp) -- | @signed space p@ parser parses an optional sign, then if there is a -- sign it will consume optional white space (using @space@ parser), then it -- runs parser @p@ which should return a number. Sign of the number is -- changed according to previously parsed sign. -- -- For example, to parse signed integer you can write: -- -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.integer -- > signedInteger = L.signed spaceConsumer integer signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a signed spc p = ($) <$> option id (lexeme spc sign) <*> p -- | Parse a sign and return either 'id' or 'negate' according to parsed -- sign. sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a) sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate) megaparsec-5.3.1/Text/Megaparsec/Perm.hs0000644000000000000000000001267213123732303016254 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Perm -- Copyright : © 2015–2017 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.3.1/Text/Megaparsec/Pos.hs0000644000000000000000000001272613123732303016112 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Pos -- Copyright : © 2015–2017 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 a 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 Test.QuickCheck #if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Word (Word) #endif ---------------------------------------------------------------------------- -- Abstract position -- | Positive integer that is used to represent line number, column number, -- and similar things like indentation level. 'Semigroup' instance can be -- used to safely and purely add 'Pos'es together. -- -- @since 5.0.0 newtype Pos = Pos Word deriving (Show, Eq, Ord, Data, Typeable, NFData) instance Arbitrary Pos where arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0)) -- | Construction of 'Pos' from an instance of 'Integral'. The function -- throws 'InvalidPosException' when given non-positive argument. Note that -- the function is polymorphic with respect to 'MonadThrow' @m@, so you can -- get result inside of 'Maybe', for example. -- -- @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 (Pos w) = w {-# 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) instance Arbitrary SourcePos where arbitrary = SourcePos <$> sized (\n -> do k <- choose (0, n `div` 2) vectorOf k arbitrary) <*> (unsafePos <$> choose (1, 1000)) <*> (unsafePos <$> choose (1, 100)) -- | 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 the tab width. If the character is a newline (\'\\n\') the line -- number is incremented by 1. If the character is a tab (\'\\t\') the -- column number is incremented to the nearest tab position. In all other -- cases, the column is incremented by 1. -- -- @since 5.0.0 defaultUpdatePos :: Pos -- ^ Tab width -> SourcePos -- ^ Current position -> Char -- ^ Current token -> (SourcePos, SourcePos) -- ^ Actual position and incremented position defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos) where u = unsafePos 1 w = unPos width c' = unPos c npos = case ch of '\n' -> SourcePos n (l <> u) u '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w)) _ -> SourcePos n l (c <> u) -- | Value of tab width used by default. Always prefer this constant when -- you want to refer to the default tab width because actual value /may/ -- change in future. defaultTabWidth :: Pos defaultTabWidth = unsafePos 8 megaparsec-5.3.1/Text/Megaparsec/Prim.hs0000644000000000000000000014371313123733000016254 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Prim -- Copyright : © 2015–2017 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 RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} module Text.Megaparsec.Prim ( -- * Data types State (..) , Stream (..) , Parsec , ParsecT -- * Primitive combinators , MonadParsec (..) , () , unexpected , match , region -- * Parser state combinators , getInput , setInput , getPosition , getNextTokenPosition , setPosition , pushPosition , popPosition , getTokensProcessed , setTokensProcessed , getTabWidth , setTabWidth , setParserState -- * Running parser , parse , parseMaybe , parseTest , runParser , runParser' , runParserT , runParserT' -- * Debugging , dbg ) where import Control.DeepSeq import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.Identity import Control.Monad.Reader.Class import Control.Monad.State.Class hiding (state) import Control.Monad.Trans import Control.Monad.Trans.Identity import Data.Data (Data) import Data.Foldable (foldl') import Data.List (genericTake) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid hiding ((<>)) import Data.Proxy import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import Debug.Trace import GHC.Generics import Prelude hiding (all) import Test.QuickCheck hiding (Result (..), label) import qualified Control.Applicative as A import qualified Control.Monad.Fail as Fail import qualified Control.Monad.RWS.Lazy as L import qualified Control.Monad.RWS.Strict as S import qualified Control.Monad.Trans.Reader as L import qualified Control.Monad.Trans.State.Lazy as L import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Lazy as L import qualified Control.Monad.Trans.Writer.Strict as S import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.List.NonEmpty as NE import qualified Data.Set as E import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Text.Megaparsec.Error import Text.Megaparsec.Pos #if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Word (Word) #endif ---------------------------------------------------------------------------- -- Data types -- | This is the Megaparsec's state, it's parametrized over stream type @s@. data State s = State { stateInput :: s -- ^ Current input (already processed input is removed from the stream) , statePos :: NonEmpty SourcePos -- ^ Current position (column + line number) with support for include files , stateTokensProcessed :: {-# UNPACK #-} !Word -- ^ Number of processed tokens so far -- -- @since 5.2.0 , stateTabWidth :: Pos -- ^ Tab width to use } deriving (Show, Eq, Data, Typeable, Generic) instance NFData s => NFData (State s) instance Arbitrary a => Arbitrary (State a) where arbitrary = State <$> arbitrary <*> (NE.fromList . getNonEmpty <$> arbitrary) <*> choose (1, 10000) <*> (unsafePos <$> choose (1, 20)) -- | All information available after parsing. This includes consumption of -- input, success (with returned value) or failure (with parse error), and -- parser state at the end of parsing. -- -- See also: 'Consumption', 'Result'. data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) -- | This data structure represents an aspect of result of parser's work. -- -- See also: 'Result', 'Reply'. data Consumption = Consumed -- ^ Some part of input stream was consumed | Virgin -- ^ No input was consumed -- | This data structure represents an aspect of result of parser's work. -- -- See also: 'Consumption', 'Reply'. data Result t e a = OK a -- ^ Parser succeeded | Error (ParseError t e) -- ^ Parser failed -- | 'Hints' represent collection of strings to be included into -- 'ParserError' as “expected” message items when a parser fails without -- consuming input right after successful parser that produced the hints. -- -- For example, without hints you could get: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2: -- unexpected 'a' -- expecting end of input -- -- We're getting better error messages with help of hints: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid) -- | Convert 'ParseError' record into 'Hints'. toHints :: ParseError t e -> Hints t toHints err = Hints hints where hints = if E.null msgs then [] else [msgs] msgs = errorExpected err {-# INLINE toHints #-} -- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. -- -- Note that if resulting continuation gets 'ParseError' that has only -- custom data in it (no “unexpected” or “expected” items), hints are -- ignored. withHints :: Ord (Token s) => Hints (Token s) -- ^ Hints to use -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence -> ParseError (Token s) e -- ^ First argument of resulting continuation -> State s -- ^ Second argument of resulting continuation -> m b withHints (Hints ps') c e@(ParseError pos us ps xs) = if E.null us && E.null ps && not (E.null xs) then c e else c (ParseError pos us (E.unions (ps : ps')) xs) {-# INLINE withHints #-} -- | @accHints hs c@ results in “OK” continuation that will add given hints -- @hs@ to third argument of original continuation @c@. accHints :: Hints t -- ^ 'Hints' to add -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter -> a -- ^ First argument of resulting continuation -> State s -- ^ Second argument of resulting continuation -> Hints t -- ^ Third argument of resulting continuation -> m b accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} -- | Replace the most recent group of hints (if any) with the given -- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label' -- primitive. refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t refreshLastHint (Hints []) _ = Hints [] refreshLastHint (Hints (_:xs)) Nothing = Hints xs refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) {-# INLINE refreshLastHint #-} -- | An instance of @Stream s@ has stream type @s@. Token type is determined -- by the stream and can be found via 'Token' type function. class Ord (Token s) => Stream s where -- | Type of token in stream. -- -- @since 5.0.0 type Token s :: * -- | Get next token from the stream. If the stream is empty, return -- 'Nothing'. uncons :: s -> Maybe (Token s, s) -- | Update position in stream given tab width, current position, and -- current token. The result is a tuple where the first element will be -- used to report parse errors for current token, while the second element -- is the incremented position that will be stored in the parser's state. -- The stored (incremented) position is used whenever position can't -- be\/shouldn't be updated by consuming a token. For example, when using -- 'failure', we don't grab a new token (we need to fail right were we are -- now), so error position will be taken from parser's state. -- -- When you work with streams where elements do not contain information -- about their position in input, the result is usually consists of the -- third argument unchanged and incremented position calculated with -- respect to current token. This is how default instances of 'Stream' -- work (they use 'defaultUpdatePos', which may be a good starting point -- for your own position-advancing function). -- -- When you wish to deal with a stream of tokens where every token “knows” -- its start and end position in input (for example, you have produced the -- stream with Happy\/Alex), then the best strategy is to use the start -- position as the actual element position and provide the end position of -- the token as the incremented one. -- -- @since 5.0.0 updatePos :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective) -> Pos -- ^ Tab width -> SourcePos -- ^ Current position -> Token s -- ^ Current token -> (SourcePos, SourcePos) -- ^ Actual position and incremented position instance Stream String where type Token String = Char uncons [] = Nothing uncons (t:ts) = Just (t, ts) {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream B.ByteString where type Token B.ByteString = Char uncons = B.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream BL.ByteString where type Token BL.ByteString = Char uncons = BL.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream T.Text where type Token T.Text = Char uncons = T.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} instance Stream TL.Text where type Token TL.Text = Char uncons = TL.uncons {-# INLINE uncons #-} updatePos = const defaultUpdatePos {-# INLINE updatePos #-} -- | @Parsec@ is a non-transformer variant of the more general 'ParsecT' -- monad transformer. type Parsec e s = ParsecT e s Identity -- | @ParsecT e s m a@ is a parser with custom data component of error @e@, -- stream type @s@, underlying monad @m@ and return type @a@. newtype ParsecT e s m a = ParsecT { unParser :: forall b. State s -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK -> (ParseError (Token s) e -> State s -> m b) -- consumed-error -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK -> (ParseError (Token s) e -> State s -> m b) -- empty-error -> m b } instance (ErrorComponent e, Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where (<>) = A.liftA2 (<>) {-# INLINE (<>) #-} instance (ErrorComponent e, Stream s, Monoid a) => Monoid (ParsecT e s m a) where mempty = pure mempty {-# INLINE mempty #-} mappend = A.liftA2 mappend {-# INLINE mappend #-} instance Functor (ParsecT e s m) where fmap = pMap pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b pMap f p = ParsecT $ \s cok cerr eok eerr -> unParser p s (cok . f) cerr (eok . f) eerr {-# INLINE pMap #-} instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where pure = pPure (<*>) = pAp p1 *> p2 = p1 `pBind` const p2 p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } pAp :: Stream s => ParsecT e s m (a -> b) -> ParsecT e s m a -> ParsecT e s m b pAp m k = ParsecT $ \s cok cerr eok eerr -> let mcok x s' hs = unParser k s' (cok . x) cerr (accHints hs (cok . x)) (withHints hs cerr) meok x s' hs = unParser k s' (cok . x) cerr (accHints hs (eok . x)) (withHints hs eerr) in unParser m s mcok cerr meok eerr {-# INLINE pAp #-} instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where empty = mzero (<|>) = mplus instance (ErrorComponent e, Stream s) => Monad (ParsecT e s m) where return = pure (>>=) = pBind fail = Fail.fail pPure :: a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} pBind :: Stream s => ParsecT e s m a -> (a -> ParsecT e s m b) -> ParsecT e s m b pBind m k = ParsecT $ \s cok cerr eok eerr -> let mcok x s' hs = unParser (k x) s' cok cerr (accHints hs cok) (withHints hs cerr) meok x s' hs = unParser (k x) s' cok cerr (accHints hs eok) (withHints hs eerr) in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} instance (ErrorComponent e, Stream s) => Fail.MonadFail (ParsecT e s m) where fail = pFail pFail :: ErrorComponent e => String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty d) s where d = E.singleton (representFail msg) {-# INLINE pFail #-} mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a mkPT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of OK x -> cok x s' mempty Error e -> cerr e s' Virgin -> case result of OK x -> eok x s' mempty Error e -> eerr e s' instance (ErrorComponent e, Stream s, MonadIO m) => MonadIO (ParsecT e s m) where liftIO = lift . liftIO instance (ErrorComponent e, Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where ask = lift ask local f p = mkPT $ \s -> local f (runParsecT p s) instance (ErrorComponent e, Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put instance (ErrorComponent e, Stream s, MonadCont m) => MonadCont (ParsecT e s m) where callCC f = mkPT $ \s -> callCC $ \c -> runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s where pack s a = Reply s Virgin (OK a) instance (ErrorComponent e, Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError p `catchError` h = mkPT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s instance (ErrorComponent e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus pZero :: ParsecT e s m a pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty E.empty) s {-# INLINE pZero #-} pPlus :: (ErrorComponent e, Stream s) => ParsecT e s m a -> ParsecT e s m a -> ParsecT e s m a pPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err ms = let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') neok x s' hs = eok x s' (toHints err <> hs) neerr err' s' = eerr (err' <> err) (longestMatch ms s') in unParser n s cok ncerr neok neerr in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} -- | From two states, return the one with the greater number of processed -- tokens. If the numbers of processed tokens are equal, prefer the second -- state. longestMatch :: State s -> State s -> State s longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) = case tp1 `compare` tp2 of LT -> s2 EQ -> s2 GT -> s1 {-# INLINE longestMatch #-} instance MonadTrans (ParsecT e s) where lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty ---------------------------------------------------------------------------- -- Primitive combinators -- | Type class describing parsers independent of input type. class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m) => MonadParsec e s m | m -> e s where -- | The most general way to stop parsing and report a 'ParseError'. -- -- 'unexpected' is defined in terms of this function: -- -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty -- -- @since 4.2.0 failure :: Set (ErrorItem (Token s)) -- ^ Unexpected items -> Set (ErrorItem (Token s)) -- ^ Expected items -> Set e -- ^ Custom data -> m a -- | The parser @label name p@ behaves as parser @p@, but whenever the -- parser @p@ fails /without consuming any input/, it replaces names of -- “expected” tokens with the name @name@. label :: String -> m a -> m a -- | @hidden p@ behaves just like parser @p@, but it doesn't show any -- “expected” tokens in error message when @p@ fails. hidden :: m a -> m a hidden = label "" -- | The parser @try p@ behaves like parser @p@, except that it backtracks -- the parser state when @p@ fails (either consuming input or not). -- -- This combinator is used whenever arbitrary look ahead is needed. Since -- it pretends that it hasn't consumed any input when @p@ fails, the -- ('A.<|>') combinator will try its second alternative even when the -- first parser failed while consuming input. -- -- For example, here is a parser that is supposed to parse the word “let” -- or the word “lexical”: -- -- >>> parseTest (string "let" <|> string "lexical") "lexical" -- 1:1: -- unexpected "lex" -- expecting "let" -- -- What happens here? The first parser consumes “le” and fails (because it -- doesn't see a “t”). The second parser, however, isn't tried, since the -- first parser has already consumed some input! 'try' fixes this behavior -- and allows backtracking to work: -- -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" -- "lexical" -- -- @try@ also improves error messages in case of overlapping alternatives, -- because Megaparsec's hint system can be used: -- -- >>> parseTest (try (string "let") <|> string "lexical") "le" -- 1:1: -- unexpected "le" -- expecting "let" or "lexical" -- -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks -- automatically (see 'tokens'), so it does not need 'try'. However, the -- examples above demonstrate the idea behind 'try' so well that it was -- decided to keep them. You still need to use 'try' when your -- alternatives are complex, composite parsers. try :: m a -> m a -- | If @p@ in @lookAhead p@ succeeds (either consuming input or not) the -- whole parser behaves like @p@ succeeded without consuming anything -- (parser state is not updated as well). If @p@ fails, @lookAhead@ has no -- effect, i.e. it will fail consuming input if @p@ fails consuming input. -- Combine with 'try' if this is undesirable. lookAhead :: m a -> m a -- | @notFollowedBy p@ only succeeds when the parser @p@ fails. This -- parser /never consumes/ any input and /never modifies/ parser state. It -- can be used to implement the “longest match” rule. notFollowedBy :: m a -> m () -- | @withRecovery r p@ allows continue parsing even if parser @p@ fails. -- In this case @r@ is called with the actual 'ParseError' as its -- argument. Typical usage is to return a value signifying failure to -- parse this particular object and to consume some part of the input up -- to the point where the next object starts. -- -- Note that if @r@ fails, original error message is reported as if -- without 'withRecovery'. In no way recovering parser @r@ can influence -- error messages. -- -- @since 4.4.0 withRecovery :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure -> m a -- ^ Original parser -> m a -- ^ Parser that can recover from failures -- | @observing p@ allows to “observe” failure of the @p@ parser, should -- it happen, without actually ending parsing, but instead getting the -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' -- as usual. Note that this primitive just allows you to observe parse -- errors as they happen, it does not backtrack or change how the @p@ -- parser works in any way. -- -- @since 5.1.0 observing :: m a -> m (Either (ParseError (Token s) e) a) -- | This parser only succeeds at the end of the input. eof :: m () -- | The parser @token test mrep@ accepts a token @t@ with result @x@ when -- the function @test t@ returns @'Right' x@. @mrep@ may provide -- representation of the token to report in error messages when input -- stream in empty. -- -- This is the most primitive combinator for accepting tokens. For -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: -- -- > satisfy f = token testChar Nothing -- > where -- > testChar x = -- > if f x -- > then Right x -- > else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty) token :: (Token s -> Either ( Set (ErrorItem (Token s)) , Set (ErrorItem (Token s)) , Set e ) a) -- ^ Matching function for the token to parse, it allows to construct -- arbitrary error message on failure as well; sets in three-tuple -- are: unexpected items, expected items, and custom data pieces -> Maybe (Token s) -- ^ Token to report when input stream is empty -> m a -- | The parser @tokens test@ parses a list of tokens and returns it. -- Supplied predicate @test@ is used to check equality of given and parsed -- tokens. -- -- This can be used for example to write 'Text.Megaparsec.Char.string': -- -- > string = tokens (==) -- -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking -- primitive, which means that if it fails, it never consumes any input. -- This is done to make its consumption model match how error messages for -- this primitive are reported (which becomes an important thing as user -- gets more control with primitives like 'withRecovery'): -- -- >>> parseTest (string "abc") "abd" -- 1:1: -- unexpected "abd" -- expecting "abc" -- -- This means, in particular, that it's no longer necessary to use 'try' -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect -- performance in any way. tokens :: (Token s -> Token s -> Bool) -- ^ Predicate to check equality of tokens -> [Token s] -- ^ List of tokens to parse -> m [Token s] -- | Return the full parser state as a 'State' record. getParserState :: m (State s) -- | @updateParserState f@ applies the function @f@ to the parser state. updateParserState :: (State s -> State s) -> m () instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where failure = pFailure label = pLabel try = pTry lookAhead = pLookAhead notFollowedBy = pNotFollowedBy withRecovery = pWithRecovery observing = pObserving eof = pEof token = pToken tokens = pTokens getParserState = pGetParserState updateParserState = pUpdateParserState pFailure :: Set (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> Set e -> ParsecT e s m a pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos us ps xs) s {-# INLINE pFailure #-} pLabel :: String -> ParsecT e s m a -> ParsecT e s m a pLabel l p = ParsecT $ \s cok cerr eok eerr -> let el = Label <$> NE.nonEmpty l cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l cok' x s' hs = cok x s' (refreshLastHint hs cl) eok' x s' hs = eok x s' (refreshLastHint hs el) eerr' err = eerr err { errorExpected = maybe E.empty E.singleton el } in unParser p s cok' cerr eok' eerr' {-# INLINE pLabel #-} pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr -> let eerr' err _ = eerr err s in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-} pLookAhead :: ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr -> let eok' a _ _ = eok a s mempty in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (uncons input) unexpect u = ParseError pos (E.singleton u) E.empty E.empty cok' _ _ _ = eerr (unexpect what) s cerr' _ _ = eok () s mempty eok' _ _ _ = eerr (unexpect what) s eerr' _ _ = eok () s mempty in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-} pWithRecovery :: (ParseError (Token s) e -> ParsecT e s m a) -> ParsecT e s m a -> ParsecT e s m a pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> let mcerr err ms = let rcok x s' _ = cok x s' mempty rcerr _ _ = cerr err ms reok x s' _ = eok x s' (toHints err) reerr _ _ = cerr err ms in unParser (r err) ms rcok rcerr reok reerr meerr err ms = let rcok x s' _ = cok x s' (toHints err) rcerr _ _ = eerr err ms reok x s' _ = eok x s' (toHints err) reerr _ _ = eerr err ms in unParser (r err) ms rcok rcerr reok reerr in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} pObserving :: ParsecT e s m a -> ParsecT e s m (Either (ParseError (Token s) e) a) pObserving p = ParsecT $ \s cok _ eok _ -> let cerr' err s' = cok (Left err) s' mempty eerr' err s' = eok (Left err) s' (toHints err) in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} pEof :: forall e s m. Stream s => ParsecT e s m () pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> case uncons input of Nothing -> eok () s mempty Just (x,_) -> let !apos = fst (updatePos (Proxy :: Proxy s) w pos x) in eerr ParseError { errorPos = apos:|z , errorUnexpected = (E.singleton . Tokens . nes) x , errorExpected = E.singleton EndOfInput , errorCustom = E.empty } (State input (apos:|z) tp w) {-# INLINE pEof #-} pToken :: forall e s m a. Stream s => (Token s -> Either ( Set (ErrorItem (Token s)) , Set (ErrorItem (Token s)) , Set e ) a) -> Maybe (Token s) -> ParsecT e s m a pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> case uncons input of Nothing -> eerr ParseError { errorPos = pos:|z , errorUnexpected = E.singleton EndOfInput , errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtoken , errorCustom = E.empty } s Just (c,cs) -> let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c in case test c of Left (us, ps, xs) -> apos `seq` eerr (ParseError (apos:|z) us ps xs) (State input (apos:|z) tp w) Right x -> let newstate = State cs (npos:|z) (tp + 1) w in npos `seq` cok x newstate mempty {-# INLINE pToken #-} pTokens :: forall e s m. Stream s => (Token s -> Token s -> Bool) -> [Token s] -> ParsecT e s m [Token s] pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> let updatePos' = updatePos (Proxy :: Proxy s) w toTokens = Tokens . NE.fromList . reverse unexpect pos' u = ParseError { errorPos = pos' , errorUnexpected = E.singleton u , errorExpected = (E.singleton . Tokens . NE.fromList) tts , errorCustom = E.empty } go _ [] is rs = let ris = reverse is (npos, tp') = foldl' (\(p, n) t -> (snd (updatePos' p t), n + 1)) (pos, tp) ris in cok ris (State rs (npos:|z) tp' w) mempty go apos (t:ts) is rs = case uncons rs of Nothing -> apos `seq` eerr (unexpect (apos:|z) (toTokens is)) (State input (apos:|z) tp w) Just (x,xs) -> if test t x then go apos ts (x:is) xs else apos `seq` eerr (unexpect (apos:|z) . toTokens $ x:is) (State input (apos:|z) tp w) in case uncons input of Nothing -> eerr (unexpect (pos:|z) EndOfInput) s Just (x,xs) -> let t:ts = tts apos = fst (updatePos' pos x) in if test t x then go apos ts [x] xs else apos `seq` eerr (unexpect (apos:|z) $ Tokens (nes x)) (State input (apos:|z) tp w) {-# INLINE pTokens #-} pGetParserState :: ParsecT e s m (State s) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} pUpdateParserState :: (State s -> State s) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} -- | A synonym for 'label' in the form of an operator. infix 0 () :: MonadParsec e s m => m a -> String -> m a () = flip label -- | The parser @unexpected item@ fails with an error message telling about -- unexpected item @item@ without consuming any input. unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a unexpected item = failure (E.singleton item) E.empty E.empty {-# INLINE unexpected #-} -- | Return both the result of a parse and the list of tokens that were -- consumed during parsing. This relies on the change of the -- 'stateTokensProcessed' value to evaluate how many tokens were consumed. -- -- @since 5.3.0 match :: MonadParsec e s m => m a -> m ([Token s], a) match p = do tp <- getTokensProcessed s <- getInput r <- p tp' <- getTokensProcessed return (streamTake (tp' - tp) s, r) -- | Specify how to process 'ParseError's that happen inside of this -- wrapper. As a side effect of the current implementation changing -- 'errorPos' with this combinator will also change the final 'statePos' in -- the parser state. -- -- @since 5.3.0 region :: MonadParsec e s m => (ParseError (Token s) e -> ParseError (Token s) e) -- ^ How to process 'ParseError's -> m a -- ^ The “region” that processing applies to -> m a region f m = do r <- observing m case r of Left err -> do let ParseError {..} = f err updateParserState $ \st -> st { statePos = errorPos } failure errorUnexpected errorExpected errorCustom Right x -> return x -- | Make a singleton non-empty list from a value. nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} ---------------------------------------------------------------------------- -- Parser state combinators -- | Return the current input. getInput :: MonadParsec e s m => m s getInput = stateInput <$> getParserState -- | @setInput input@ continues parsing with @input@. The 'getInput' and -- 'setInput' functions can for example be used to deal with include files. setInput :: MonadParsec e s m => s -> m () setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w) -- | Return the current source position. -- -- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'. getPosition :: MonadParsec e s m => m SourcePos getPosition = NE.head . statePos <$> getParserState -- | Get the position where the next token in the stream begins. If the -- stream is empty, return 'Nothing'. -- -- @since 5.3.0 getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos) getNextTokenPosition = do State {..} <- getParserState let f = fst . updatePos (Proxy :: Proxy s) stateTabWidth (NE.head statePos) return (f . fst <$> uncons stateInput) -- | @setPosition pos@ sets the current source position to @pos@. -- -- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. setPosition :: MonadParsec e s m => SourcePos -> m () setPosition pos = updateParserState $ \(State s (_:|z) tp w) -> State s (pos:|z) tp w -- | Push a position into stack of positions and continue parsing working -- with this position. Useful for working with include files and the like. -- -- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'. -- -- @since 5.0.0 pushPosition :: MonadParsec e s m => SourcePos -> m () pushPosition pos = updateParserState $ \(State s z tp w) -> State s (NE.cons pos z) tp w -- | Pop a position from the stack of positions unless it only contains one -- element (in that case the stack of positions remains the same). This is -- how to return to previous source file after 'pushPosition'. -- -- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'. -- -- @since 5.0.0 popPosition :: MonadParsec e s m => m () popPosition = updateParserState $ \(State s z tp w) -> case snd (NE.uncons z) of Nothing -> State s z tp w Just z' -> State s z' tp w -- | Get the number of tokens processed so far. -- -- @since 5.2.0 getTokensProcessed :: MonadParsec e s m => m Word getTokensProcessed = stateTokensProcessed <$> getParserState -- | Set the number of tokens processed so far. -- -- @since 5.2.0 setTokensProcessed :: MonadParsec e s m => Word -> m () setTokensProcessed tp = updateParserState $ \(State s pos _ w) -> State s pos tp w -- | Return the tab width. The default tab width is equal to -- 'defaultTabWidth'. You can set a different tab width with the help of -- 'setTabWidth'. getTabWidth :: MonadParsec e s m => m Pos getTabWidth = stateTabWidth <$> getParserState -- | Set tab width. If the argument of the function is not a positive -- number, 'defaultTabWidth' will be used. setTabWidth :: MonadParsec e s m => Pos -> m () setTabWidth w = updateParserState $ \(State s pos tp _) -> State s pos tp w -- | @setParserState st@ sets the parser state to @st@. setParserState :: MonadParsec e s m => State s -> m () setParserState st = updateParserState (const st) ---------------------------------------------------------------------------- -- Running a parser -- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT' -- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a -- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn -- 'ParseError' into the string representation of the error message. See -- "Text.Megaparsec.Error" if you need to do more advanced error analysis. -- -- > main = case (parse numbers "" "11,2,43") of -- > Left err -> putStr (parseErrorPretty err) -- > Right xs -> print (sum xs) -- > -- > numbers = integer `sepBy` char ',' parse :: Parsec e s a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> Either (ParseError (Token s) e) a parse = runParser -- | @parseMaybe p input@ runs the parser @p@ on @input@ and returns the -- result inside 'Just' on success and 'Nothing' on failure. This function -- also parses 'eof', so if the parser doesn't consume all of its input, it -- will fail. -- -- The function is supposed to be useful for lightweight parsing, where -- error messages (and thus file name) are not important and entire input -- should be parsed. For example it can be used when parsing of a single -- number according to specification of its format is desired. parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s = case parse (p <* eof) "" s of Left _ -> Nothing Right x -> Just x -- | The expression @parseTest p input@ applies the parser @p@ against input -- @input@ and prints the result to stdout. Useful for testing. parseTest :: ( ShowErrorComponent e , Ord (Token s) , ShowToken (Token s) , Show a ) => Parsec e s a -- ^ Parser to run -> s -- ^ Input for parser -> IO () parseTest p input = case parse p "" input of Left e -> putStr (parseErrorPretty e) Right x -> print x -- | @runParser p file input@ runs parser @p@ on the input stream of tokens -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns either a 'ParseError' -- ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file runParser :: Parsec e s a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> Either (ParseError (Token s) e) a runParser p name s = snd $ runParser' p (initialState name s) -- | The function is similar to 'runParser' with the difference that it -- accepts and returns parser state. This allows to specify arbitrary -- textual position at the beginning of parsing, for example. This is the -- most general way to run a parser over the 'Identity' monad. -- -- @since 4.2.0 runParser' :: Parsec e s a -- ^ Parser to run -> State s -- ^ Initial state -> (State s, Either (ParseError (Token s) e) a) runParser' p = runIdentity . runParserT' p -- | @runParserT p file input@ runs parser @p@ on the input list of tokens -- @input@, obtained from source @file@. The @file@ is only used in error -- messages and may be the empty string. Returns a computation in the -- underlying monad @m@ that returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). runParserT :: Monad m => ParsecT e s m a -- ^ Parser to run -> String -- ^ Name of source file -> s -- ^ Input for parser -> m (Either (ParseError (Token s) e) a) runParserT p name s = snd `liftM` runParserT' p (initialState name s) -- | This function is similar to 'runParserT', but like 'runParser'' it -- accepts and returns parser state. This is thus the most general way to -- run a parser. -- -- @since 4.2.0 runParserT' :: Monad m => ParsecT e s m a -- ^ Parser to run -> State s -- ^ Initial state -> m (State s, Either (ParseError (Token s) e) a) runParserT' p s = do (Reply s' _ result) <- runParsecT p s case result of OK x -> return (s', Right x) Error e -> return (s', Left e) -- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' -- are built upon this. runParsecT :: Monad m => ParsecT e s m a -- ^ Parser to run -> State s -- ^ Initial state -> m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr where cok a s' _ = return $ Reply s' Consumed (OK a) cerr err s' = return $ Reply s' Consumed (Error err) eok a s' _ = return $ Reply s' Virgin (OK a) eerr err s' = return $ Reply s' Virgin (Error err) -- | Given name of source file and input construct initial state for parser. initialState :: String -> s -> State s initialState name s = State { stateInput = s , statePos = initialPos name :| [] , stateTokensProcessed = 0 , stateTabWidth = defaultTabWidth } ---------------------------------------------------------------------------- -- Instances of 'MonadParsec' instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where failure us ps xs = lift (failure us ps xs) label n (L.StateT m) = L.StateT $ label n . m try (L.StateT m) = L.StateT $ try . m lookAhead (L.StateT m) = L.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (L.StateT m) = L.StateT $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) withRecovery r (L.StateT m) = L.StateT $ \s -> withRecovery (\e -> L.runStateT (r e) s) (m s) observing (L.StateT m) = L.StateT $ \s -> fixs s <$> observing (m s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where failure us ps xs = lift (failure us ps xs) label n (S.StateT m) = S.StateT $ label n . m try (S.StateT m) = S.StateT $ try . m lookAhead (S.StateT m) = S.StateT $ \s -> (,s) . fst <$> lookAhead (m s) notFollowedBy (S.StateT m) = S.StateT $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) withRecovery r (S.StateT m) = S.StateT $ \s -> withRecovery (\e -> S.runStateT (r e) s) (m s) observing (S.StateT m) = S.StateT $ \s -> fixs s <$> observing (m s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where failure us ps xs = lift (failure us ps xs) label n (L.ReaderT m) = L.ReaderT $ label n . m try (L.ReaderT m) = L.ReaderT $ try . m lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> withRecovery (\e -> L.runReaderT (r e) s) (m s) observing (L.ReaderT m) = L.ReaderT $ observing . m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where failure us ps xs = lift (failure us ps xs) label n (L.WriterT m) = L.WriterT $ label n m try (L.WriterT m) = L.WriterT $ try m lookAhead (L.WriterT m) = L.WriterT $ (,mempty) . fst <$> lookAhead m notFollowedBy (L.WriterT m) = L.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) withRecovery r (L.WriterT m) = L.WriterT $ withRecovery (L.runWriterT . r) m observing (L.WriterT m) = L.WriterT $ fixs mempty <$> observing m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where failure us ps xs = lift (failure us ps xs) label n (S.WriterT m) = S.WriterT $ label n m try (S.WriterT m) = S.WriterT $ try m lookAhead (S.WriterT m) = S.WriterT $ (,mempty) . fst <$> lookAhead m notFollowedBy (S.WriterT m) = S.WriterT $ (,mempty) <$> notFollowedBy (fst <$> m) withRecovery r (S.WriterT m) = S.WriterT $ withRecovery (S.runWriterT . r) m observing (S.WriterT m) = S.WriterT $ fixs mempty <$> observing m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where failure us ps xs = lift (failure us ps xs) label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) try (L.RWST m) = L.RWST $ \r s -> try (m r s) lookAhead (L.RWST m) = L.RWST $ \r s -> do (x,_,_) <- lookAhead (m r s) return (x,s,mempty) notFollowedBy (L.RWST m) = L.RWST $ \r s -> do notFollowedBy (void $ m r s) return ((),s,mempty) withRecovery n (L.RWST m) = L.RWST $ \r s -> withRecovery (\e -> L.runRWST (n e) r s) (m r s) observing (L.RWST m) = L.RWST $ \r s -> fixs' s <$> observing (m r s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where failure us ps xs = lift (failure us ps xs) label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) try (S.RWST m) = S.RWST $ \r s -> try (m r s) lookAhead (S.RWST m) = S.RWST $ \r s -> do (x,_,_) <- lookAhead (m r s) return (x,s,mempty) notFollowedBy (S.RWST m) = S.RWST $ \r s -> do notFollowedBy (void $ m r s) return ((),s,mempty) withRecovery n (S.RWST m) = S.RWST $ \r s -> withRecovery (\e -> S.runRWST (n e) r s) (m r s) observing (S.RWST m) = S.RWST $ \r s -> fixs' s <$> observing (m r s) eof = lift eof token test mt = lift (token test mt) tokens e ts = lift (tokens e ts) getParserState = lift getParserState updateParserState f = lift (updateParserState f) instance MonadParsec e s m => MonadParsec e s (IdentityT m) where failure us ps xs = lift (failure us ps xs) label n (IdentityT m) = IdentityT $ label n m try = IdentityT . try . runIdentityT lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m withRecovery r (IdentityT m) = IdentityT $ withRecovery (runIdentityT . r) m observing (IdentityT m) = IdentityT $ observing m eof = lift eof token test mt = lift (token test mt) tokens e ts = lift $ tokens e ts getParserState = lift getParserState updateParserState f = lift $ updateParserState f fixs :: s -> Either a (b, s) -> (Either a b, s) fixs s (Left a) = (Left a, s) fixs _ (Right (b, s)) = (Right b, s) {-# INLINE fixs #-} fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) fixs' s (Left a) = (Left a, s, mempty) fixs' _ (Right (b,s,w)) = (Right b, s, w) {-# INLINE fixs' #-} ---------------------------------------------------------------------------- -- Debugging -- | @dbg label p@ parser works exactly like @p@, but when it's evaluated it -- also prints information useful for debugging. The @label@ is only used to -- refer to this parser in the debugging output. This combinator uses the -- 'trace' function from "Debug.Trace" under the hood. -- -- Typical usage is to wrap every sub-parser in misbehaving parser with -- 'dbg' assigning meaningful labels. Then give it a shot and go through the -- print-out. As of current version, this combinator prints all available -- information except for /hints/, which are probably only interesting to -- the maintainer of Megaparsec itself and may be quite verbose to output in -- general. Let me know if you would like to be able to see hints in the -- debugging output. -- -- The output itself is pretty self-explanatory, although the following -- abbreviations should be clarified (they are derived from the low-level -- source code): -- -- * @COK@—“consumed OK”. The parser consumed input and succeeded. -- * @CERR@—“consumed error”. The parser consumed input and failed. -- * @EOK@—“empty OK”. The parser succeeded without consuming input. -- * @EERR@—“empty error”. The parser failed without consuming input. -- -- Finally, it's not possible to lift this function into some monad -- transformers without introducing surprising behavior (e.g. unexpected -- state backtracking) or adding otherwise redundant constraints (e.g. -- 'Show' instance for state), so this helper is only available for -- 'ParsecT' monad, not 'MonadParsec' in general. -- -- @since 5.1.0 dbg :: forall e s m a. ( Stream s , ShowToken (Token s) , ShowErrorComponent e , Show a ) => String -- ^ Debugging label -> ParsecT e s m a -- ^ Parser to debug -> ParsecT e s m a -- ^ Parser that prints debugging messages dbg lbl p = ParsecT $ \s cok cerr eok eerr -> let l = dbgLog lbl :: DbgItem s e a -> String cok' x s' hs = flip trace (cok x s' hs) $ l (DbgIn (unfold (stateInput s))) ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x) cerr' err s' = flip trace (cerr err s') $ l (DbgIn (unfold (stateInput s))) ++ l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err) eok' x s' hs = flip trace (eok x s' hs) $ l (DbgIn (unfold (stateInput s))) ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x) eerr' err s' = flip trace (eerr err s') $ l (DbgIn (unfold (stateInput s))) ++ l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err) in unParser p s cok' cerr' eok' eerr' -- | A single piece of info to be rendered with 'dbgLog'. data DbgItem s e a = DbgIn [Token s] | DbgCOK [Token s] a | DbgCERR [Token s] (ParseError (Token s) e) | DbgEOK [Token s] a | DbgEERR [Token s] (ParseError (Token s) e) -- | Render a single piece of debugging info. dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s)) => String -- ^ Debugging label -> DbgItem s e a -- ^ Information to render -> String -- ^ Rendered result dbgLog lbl item = prefix msg where prefix = unlines . fmap ((lbl ++ "> ") ++) . lines msg = case item of DbgIn ts -> "IN: " ++ showStream ts DbgCOK ts a -> "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a DbgCERR ts e -> "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e DbgEOK ts a -> "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a DbgEERR ts e -> "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e -- | Pretty-print a list of tokens. showStream :: ShowToken t => [t] -> String showStream ts = case NE.nonEmpty ts of Nothing -> "" Just ne -> let (h, r) = splitAt 40 (showTokens ne) in if null r then h else h ++ " <…>" -- | Calculate number of consumed tokens given 'State' of parser before and -- after parsing. streamDelta :: State s -- ^ State of parser before consumption -> State s -- ^ State of parser after consumption -> Word -- ^ Number of consumed tokens streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0 -- | Extract a given number of tokens from the stream. streamTake :: Stream s => Word -> s -> [Token s] streamTake n s = genericTake n (unfold s) -- | A custom version of 'unfold' that matches signature of the 'uncons' -- method in the 'Stream' type class we use. unfold :: Stream s => s -> [Token s] unfold s = case uncons s of Nothing -> [] Just (t, s') -> t : unfold s' megaparsec-5.3.1/Text/Megaparsec/String.hs0000644000000000000000000000125313123732303016610 0ustar0000000000000000-- | -- Module : Text.Megaparsec.String -- Copyright : © 2015–2017 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 the user can use it to easily change type of input stream -- by importing different “type modules”. This one is for 'String's. type Parser = Parsec Dec String megaparsec-5.3.1/Text/Megaparsec/Text.hs0000644000000000000000000000125713123732303016272 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Text -- Copyright : © 2015–2017 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 the user can use it to easily change type of input stream -- by importing different “type modules”. This one is for strict 'Text'. type Parser = Parsec Dec Text megaparsec-5.3.1/Text/Megaparsec/Text/Lazy.hs0000644000000000000000000000130113123732303017177 0ustar0000000000000000-- | -- Module : Text.Megaparsec.Text.Lazy -- Copyright : © 2015–2017 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 the user can use it to easily change type of the input -- stream by importing different “type modules”. This one is for lazy -- 'Text'. type Parser = Parsec Dec Text megaparsec-5.3.1/tests/Spec.hs0000644000000000000000000000005413116223306014401 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} megaparsec-5.3.1/tests/Test/Hspec/Megaparsec.hs0000644000000000000000000002732513123732303017551 0ustar0000000000000000-- | -- Module : Test.Hspec.Megaparsec -- Copyright : © 2016–2017 Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Utility functions for testing Megaparsec parsers with Hspec. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Test.Hspec.Megaparsec ( -- * Basic expectations shouldParse , parseSatisfies , shouldSucceedOn , shouldFailOn -- * Testing of error messages , shouldFailWith -- * Error message construction -- $errmsg , err , posI , posN , EC , utok , utoks , ulabel , ueof , etok , etoks , elabel , eeof , cstm -- * Incremental parsing , failsLeaving , succeedsLeaving , initialState ) where import Control.Monad (unless) import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Generics import Test.Hspec.Expectations import Text.Megaparsec import Text.Megaparsec.Pos (defaultTabWidth) import qualified Data.List.NonEmpty as NE import qualified Data.Set as E ---------------------------------------------------------------------------- -- Basic expectations -- | Create an expectation by saying what the result should be. -- -- > parse letterChar "" "x" `shouldParse` 'x' shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a) => Either (ParseError t e) a -- ^ Result of parsing as returned by function like 'parse' -> a -- ^ Desired result -> Expectation r `shouldParse` v = case r of Left e -> expectationFailure $ "expected: " ++ show v ++ "\nbut parsing failed with error:\n" ++ showParseError e Right x -> unless (x == v) . expectationFailure $ "expected: " ++ show v ++ "\nbut got: " ++ show x -- | Create an expectation by saying that the parser should successfully -- parse a value and that the value should satisfy some predicate. -- -- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length) parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) => Either (ParseError t e) a -- ^ Result of parsing as returned by function like 'parse' -> (a -> Bool) -- ^ Predicate -> Expectation r `parseSatisfies` p = case r of Left e -> expectationFailure $ "expected a parsed value to check against the predicate" ++ "\nbut parsing failed with error:\n" ++ showParseError e Right x -> unless (p x) . expectationFailure $ "the value did not satisfy the predicate: " ++ show x -- | Check that a parser fails on a given input. -- -- > parse (char 'x') "" `shouldFailOn` "a" shouldFailOn :: Show a => (s -> Either (ParseError t e) a) -- ^ Parser that takes stream and produces result or error message -> s -- ^ Input that the parser should fail on -> Expectation p `shouldFailOn` s = shouldFail (p s) -- | Check that a parser succeeds on a given input. -- -- > parse (char 'x') "" `shouldSucceedOn` "x" shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) => (s -> Either (ParseError t e) a) -- ^ Parser that takes stream and produces result or error message -> s -- ^ Input that the parser should succeed on -> Expectation p `shouldSucceedOn` s = shouldSucceed (p s) ---------------------------------------------------------------------------- -- Testing of error messages -- | Create an expectation that parser should fail producing certain -- 'ParseError'. Use the 'err' function from this module to construct a -- 'ParseError' to compare with. -- -- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x') shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) => Either (ParseError t e) a -> ParseError t e -> Expectation r `shouldFailWith` e = case r of Left e' -> unless (e == e') . expectationFailure $ "the parser is expected to fail with:\n" ++ showParseError e ++ "but it failed with:\n" ++ showParseError e' Right v -> expectationFailure $ "the parser is expected to fail, but it parsed: " ++ show v ---------------------------------------------------------------------------- -- Error message construction -- $errmsg -- -- When you wish to test error message on failure, the need to construct a -- error message for comparison arises. These helpers allow to construct -- virtually any sort of error message easily. -- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To -- create source position, two helpers are available: 'posI' and 'posN'. -- @'EC' t e@ is a monoid and can be built from primitives provided by this -- module, see below. -- -- @since 0.3.0 err :: NonEmpty SourcePos -- ^ 'ParseError' position -> EC t e -- ^ Error components -> ParseError t e -- ^ Resulting 'ParseError' err pos (EC u e c) = ParseError pos u e c -- | Initial source position with empty file name. -- -- @since 0.3.0 posI :: NonEmpty SourcePos posI = initialPos "" :| [] -- | @posN n s@ returns source position achieved by applying 'updatePos' -- method corresponding to type of stream @s@ @n@ times. -- -- @since 0.3.0 posN :: forall s n. (Stream s, Integral n) => n -> s -> NonEmpty SourcePos posN n see = f (initialPos "") see n :| [] where f p s !i = if i > 0 then case uncons s of Nothing -> p Just (t,s') -> let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t in f p' s' (i - 1) else p -- | Auxiliary type for construction of 'ParseError's. Note that it's a -- monoid. -- -- @since 0.3.0 data EC t e = EC { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items , ecExpected :: Set (ErrorItem t) -- ^ Expected items , _ecCustom :: Set e -- ^ Custom items } deriving (Eq, Data, Typeable, Generic) instance (Ord t, Ord e) => Semigroup (EC t e) where (EC u0 e0 c0) <> (EC u1 e1 c1) = EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1) instance (Ord t, Ord e) => Monoid (EC t e) where mempty = EC E.empty E.empty E.empty mappend = (<>) -- | Construct an “unexpected token” error component. -- -- @since 0.3.0 utok :: (Ord t, Ord e) => t -> EC t e utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t } -- | Construct an “unexpected tokens” error component. Empty string produces -- 'EndOfInput'. -- -- @since 0.3.0 utoks :: (Ord t, Ord e) => [t] -> EC t e utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t } -- | Construct an “unexpected label” error component. Do not use with empty -- strings (for empty strings it's bottom). -- -- @since 0.3.0 ulabel :: (Ord t, Ord e) => String -> EC t e ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l } -- | Construct an “unexpected end of input” error component. -- -- @since 0.3.0 ueof :: (Ord t, Ord e) => EC t e ueof = mempty { ecUnexpected = E.singleton EndOfInput } -- | Construct an “expected token” error component. -- -- @since 0.3.0 etok :: (Ord t, Ord e) => t -> EC t e etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t } -- | Construct an “expected tokens” error component. Empty string produces -- 'EndOfInput'. -- -- @since 0.3.0 etoks :: (Ord t, Ord e) => [t] -> EC t e etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t } -- | Construct an “expected label” error component. Do not use with empty -- strings. -- -- @since 0.3.0 elabel :: (Ord t, Ord e) => String -> EC t e elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l } -- | Construct an “expected end of input” error component. -- -- @since 0.3.0 eeof :: (Ord t, Ord e) => EC t e eeof = mempty { ecExpected = E.singleton EndOfInput } -- | Construct a custom error component. -- -- @since 0.3.0 cstm :: e -> EC t e cstm e = EC E.empty E.empty (E.singleton e) ---------------------------------------------------------------------------- -- Incremental parsing -- | Check that a parser fails and leaves a certain part of input -- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' -- that support incremental parsing. -- -- > runParser' (many (char 'x') <* eof) (initialState "xxa") -- > `failsLeaving` "a" -- -- See also: 'initialState'. failsLeaving :: (Show a, Eq s, Show s, Stream s) => (State s, Either (ParseError (Token s) e) a) -- ^ Parser that takes stream and produces result along with actual -- state information -> s -- ^ Part of input that should be left unconsumed -> Expectation (st,r) `failsLeaving` s = shouldFail r >> checkUnconsumed s (stateInput st) -- | Check that a parser succeeds and leaves certain part of input -- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' -- that support incremental parsing. -- -- > runParser' (many (char 'x')) (initialState "xxa") -- > `succeedsLeaving` "a" -- -- See also: 'initialState'. succeedsLeaving :: ( ShowToken (Token s) , ShowErrorComponent e , Show a , Eq s , Show s , Stream s ) => (State s, Either (ParseError (Token s) e) a) -- ^ Parser that takes stream and produces result along with actual -- state information -> s -- ^ Part of input that should be left unconsumed -> Expectation (st,r) `succeedsLeaving` s = shouldSucceed r >> checkUnconsumed s (stateInput st) -- | Given input for parsing, construct initial state for parser (that is, -- with empty file name, default tab width and position at 1 line and 1 -- column). initialState :: s -> State s initialState s = State { stateInput = s , statePos = initialPos "" :| [] #if MIN_VERSION_megaparsec(5,2,0) , stateTokensProcessed = 0 #endif , stateTabWidth = defaultTabWidth } ---------------------------------------------------------------------------- -- Helpers -- | Expectation that argument is result of a failed parser. shouldFail :: Show a => Either (ParseError t e) a -> Expectation shouldFail r = case r of Left _ -> return () Right v -> expectationFailure $ "the parser is expected to fail, but it parsed: " ++ show v -- | Expectation that argument is result of a succeeded parser. shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) => Either (ParseError t e) a -> Expectation shouldSucceed r = case r of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ showParseError e Right _ -> return () -- | Compare two streams for equality and in the case of mismatch report it. checkUnconsumed :: (Eq s, Show s, Stream s) => s -- ^ Expected unconsumed input -> s -- ^ Actual unconsumed input -> Expectation checkUnconsumed e a = unless (e == a) . expectationFailure $ "the parser is expected to leave unconsumed input: " ++ show e ++ "\nbut it left this: " ++ show a -- | Render parse error in a way that is suitable for inserting it in a test -- suite report. showParseError :: (Ord t, ShowToken t, ShowErrorComponent e) => ParseError t e -> String showParseError = unlines . fmap (" " ++) . lines . parseErrorPretty -- | Make a singleton non-empty list from a value. nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} -- | Construct appropriate 'ErrorItem' representation for given token -- stream. Empty string produces 'EndOfInput'. canonicalizeTokens :: [t] -> ErrorItem t canonicalizeTokens ts = case NE.nonEmpty ts of Nothing -> EndOfInput Just xs -> Tokens xs megaparsec-5.3.1/tests/Test/Hspec/Megaparsec/AdHoc.hs0000644000000000000000000001203213123732303020514 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} module Test.Hspec.Megaparsec.AdHoc ( -- * Helpers to run parsers prs , prs' , prs_ , grs , grs' -- * Working with source position , updatePosString , pos1 , nes -- * Other , abcRow , toFirstMismatch ) where import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Identity import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Test.Hspec import Test.Hspec.Megaparsec import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import qualified Control.Monad.RWS.Lazy as L import qualified Control.Monad.RWS.Strict as S import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L import qualified Control.Monad.Writer.Strict as S #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif ---------------------------------------------------------------------------- -- Helpers to run parsers -- | Apply parser to given input. This is a specialized version of 'parse' -- that assumes empty file name. prs :: Parsec Dec String a -- ^ Parser to run -> String -- ^ Input for the parser -> Either (ParseError Char Dec) a -- ^ Result of parsing prs p = parse p "" {-# INLINE prs #-} -- | Just like 'prs', but allows to inspect final state of the parser. prs' :: Parsec Dec String a -- ^ Parser to run -> String -- ^ Input for the parser -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing prs' p s = runParser' p (initialState s) {-# INLINE prs' #-} -- | Just like 'prs', but forces the parser to consume all input by adding -- 'eof': -- -- > prs_ p = parse (p <* eof) "" prs_ :: Parsec Dec String a -- ^ Parser to run -> String -- ^ Input for the parser -> Either (ParseError Char Dec) a -- ^ Result of parsing prs_ p = parse (p <* eof) "" {-# INLINE prs_ #-} -- | Just like 'prs', but interprets given parser as various monads (tries -- all supported monads transformers in turn). grs :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run -> String -- ^ Input for the parser -> (Either (ParseError Char Dec) a -> Expectation) -- ^ How to check result of parsing -> Expectation grs p s r = do r (prs p s) r (prs (runIdentityT p) s) r (prs (runReaderT p ()) s) r (prs (L.evalStateT p ()) s) r (prs (S.evalStateT p ()) s) r (prs (evalWriterTL p) s) r (prs (evalWriterTS p) s) r (prs (evalRWSTL p) s) r (prs (evalRWSTS p) s) -- | 'grs'' to 'grs' as 'prs'' to 'prs'. grs' :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run -> String -- ^ Input for the parser -> ((State String, Either (ParseError Char Dec) a) -> Expectation) -- ^ How to check result of parsing -> Expectation grs' p s r = do r (prs' p s) r (prs' (runIdentityT p) s) r (prs' (runReaderT p ()) s) r (prs' (L.evalStateT p ()) s) r (prs' (S.evalStateT p ()) s) r (prs' (evalWriterTL p) s) r (prs' (evalWriterTS p) s) r (prs' (evalRWSTL p) s) r (prs' (evalRWSTS p) s) 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 evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a evalRWSTL m = do (a,_,_) <- L.runRWST m () () return a evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a evalRWSTS m = do (a,_,_) <- S.runRWST m () () return a ---------------------------------------------------------------------------- -- Working with source position -- | 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) -- | Position with minimal value. pos1 :: Pos pos1 = unsafePos 1 -- | Make a singleton non-empty list from a value. nes :: a -> NonEmpty a nes x = x :| [] {-# INLINE nes #-} ---------------------------------------------------------------------------- -- Other -- | @abcRow a b c@ generates string consisting of character “a” repeated -- @a@ times, character “b” repeated @b@ times, and character “c” repeated -- @c@ times. abcRow :: Int -> Int -> Int -> String abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' -- | Given a comparing function, get prefix of one string till first -- mismatch with another string (including first mismatching character). toFirstMismatch :: (Char -> Char -> Bool) -- ^ Comparing function -> String -- ^ First string -> String -- ^ Second string -> String -- ^ Resulting prefix toFirstMismatch f str s = take (n + 1) s where n = length (takeWhile (uncurry f) (zip str s)) megaparsec-5.3.1/tests/Text/Megaparsec/CharSpec.hs0000644000000000000000000004020313124146522020175 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS -fno-warn-orphans #-} module Text.Megaparsec.CharSpec (spec) where import Control.Monad import Data.Char import Data.List (partition, isPrefixOf) import Data.Monoid ((<>)) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Error import Text.Megaparsec.Prim #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif instance Arbitrary GeneralCategory where arbitrary = elements [minBound..maxBound] spec :: Spec spec = do describe "newline" $ checkStrLit "newline" "\n" (pure <$> newline) describe "csrf" $ checkStrLit "crlf newline" "\r\n" crlf describe "eol" $ do context "when stream begins with a newline" $ it "succeeds returning the newline" $ property $ \s -> do let s' = '\n' : s prs eol s' `shouldParse` "\n" prs' eol s' `succeedsLeaving` s context "when stream begins with CRLF sequence" $ it "parses the CRLF sequence" $ property $ \s -> do let s' = '\r' : '\n' : s prs eol s' `shouldParse` "\r\n" prs' eol s' `succeedsLeaving` s context "when stream begins with '\\r', but it's not followed by '\\n'" $ it "signals correct parse error" $ property $ \ch -> ch /= '\n' ==> do let s = ['\r',ch] prs eol s `shouldFailWith` err posI (utoks s <> utok '\r' <> elabel "end of line") context "when input stream is '\\r'" $ it "signals correct parse error" $ prs eol "\r" `shouldFailWith` err posI (utok '\r' <> elabel "end of line") context "when stream does not begin with newline or CRLF sequence" $ it "signals correct parse error" $ property $ \ch s -> (ch `notElem` "\r\n") ==> do let s' = ch : s prs eol s' `shouldFailWith` err posI (utok ch <> elabel "end of line") context "when stream is empty" $ it "signals correct parse error" $ prs eol "" `shouldFailWith` err posI (ueof <> elabel "end of line") describe "tab" $ checkStrLit "tab" "\t" (pure <$> tab) describe "space" $ it "consumes it up to first non-space character" $ property $ \s -> do let (s0,s1) = partition isSpace s s' = s0 ++ s1 prs space s' `shouldParse` () prs' space s' `succeedsLeaving` s1 describe "controlChar" $ checkCharPred "control character" isControl controlChar describe "spaceChar" $ checkCharRange "white space" " \160\t\n\r\f\v" spaceChar describe "upperChar" $ checkCharPred "uppercase letter" isUpper upperChar describe "lowerChar" $ checkCharPred "lowercase letter" isLower lowerChar describe "letterChar" $ checkCharPred "letter" isAlpha letterChar describe "alphaNumChar" $ checkCharPred "alphanumeric character" isAlphaNum alphaNumChar describe "printChar" $ checkCharPred "printable character" isPrint printChar describe "digitChar" $ checkCharRange "digit" ['0'..'9'] digitChar describe "octDigitChar" $ checkCharRange "octal digit" ['0'..'7'] octDigitChar describe "hexDigitChar" $ checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar describe "markChar" $ #if MIN_VERSION_base(4,9,0) checkCharRange "mark character" "\71229\7398" markChar #else checkCharRange "mark character" "" markChar #endif describe "numberChar" $ let xs = "\185\178\179\188\189\190" ++ ['0'..'9'] in checkCharRange "numeric character" xs numberChar describe "punctuationChar" $ checkCharPred "punctuation" isPunctuation punctuationChar describe "symbolChar" $ #if MIN_VERSION_base(4,8,0) checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar #else checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar #endif describe "separatorChar" $ checkCharRange "separator" " \160" separatorChar describe "asciiChar" $ checkCharPred "ASCII character" isAscii asciiChar describe "latin1Char" $ do context "when stream begins with Latin-1 character" $ it "parses the Latin-1 character" $ property $ \ch s -> isLatin1 ch ==> do let s' = ch : s prs latin1Char s' `shouldParse` ch prs' latin1Char s' `succeedsLeaving` s context "when stream does not begin with Latin-1 character" $ it "signals correct parse error" $ do prs latin1Char "б" `shouldFailWith` err posI (utok 'б' <> elabel "Latin-1 character") prs' latin1Char "в" `failsLeaving` "в" context "when stream is empty" $ it "signals correct parse error" $ prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character") describe "charCategory" $ do context "when parser corresponding to general category of next char is used" $ it "succeeds" $ property $ \ch s -> do let s' = ch : s g = generalCategory ch prs (charCategory g) s' `shouldParse` ch prs' (charCategory g) s' `succeedsLeaving` s context "when parser's category does not match next character's category" $ it "fails" $ property $ \g ch s -> (generalCategory ch /= g) ==> do let s' = ch : s prs (charCategory g) s' `shouldFailWith` err posI (utok ch <> elabel (categoryName g)) prs' (charCategory g) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \g -> prs (charCategory g) "" `shouldFailWith` err posI (ueof <> elabel (categoryName g)) describe "char" $ do context "when stream begins with the character specified as argument" $ it "parses the character" $ property $ \ch s -> do let s' = ch : s prs (char ch) s' `shouldParse` ch prs' (char ch) s' `succeedsLeaving` s context "when stream does not begin with the character specified as argument" $ it "signals correct parse error" $ property $ \ch ch' s -> ch /= ch' ==> do let s' = ch' : s prs (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch) prs' (char ch) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \ch -> prs (char ch) "" `shouldFailWith` err posI (ueof <> etok ch) describe "char'" $ do context "when stream begins with the character specified as argument" $ it "parses the character" $ property $ \ch s -> do let sl = toLower ch : s su = toUpper ch : s prs (char' ch) sl `shouldParse` toLower ch prs (char' ch) su `shouldParse` toUpper ch prs' (char' ch) sl `succeedsLeaving` s prs' (char' ch) su `succeedsLeaving` s context "when stream does not begin with the character specified as argument" $ it "signals correct parse error" $ property $ \ch ch' s -> toLower ch /= toLower ch' ==> do let s' = ch' : s ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) prs (char' ch) s' `shouldFailWith` err posI ms prs' (char' ch) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \ch -> do let ms = ueof <> etok (toLower ch) <> etok (toUpper ch) prs (char' ch) "" `shouldFailWith` err posI ms describe "anyChar" $ do context "when stream is not empty" $ it "succeeds consuming next character in the stream" $ property $ \ch s -> do let s' = ch : s prs anyChar s' `shouldParse` ch prs' anyChar s' `succeedsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character") describe "oneOf" $ do context "when stream begins with one of specified characters" $ it "parses the character" $ property $ \chs' n s -> do let chs = getNonEmpty chs' ch = chs !! (getNonNegative n `rem` length chs) s' = ch : s prs (oneOf chs) s' `shouldParse` ch prs' (oneOf chs) s' `succeedsLeaving` s context "when stream does not begin with any of specified characters" $ it "signals correct parse error" $ property $ \chs ch s -> ch `notElem` (chs :: String) ==> do let s' = ch : s prs (oneOf chs) s' `shouldFailWith` err posI (utok ch) prs' (oneOf chs) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \chs -> prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof describe "oneOf'" $ do context "when stream begins with one of specified characters" $ it "parses the character" $ property $ \chs' n s -> do let chs = getNonEmpty chs' ch = chs !! (getNonNegative n `rem` length chs) sl = toLower ch : s su = toUpper ch : s prs (oneOf' chs) sl `shouldParse` toLower ch prs (oneOf' chs) su `shouldParse` toUpper ch prs' (oneOf' chs) sl `succeedsLeaving` s prs' (oneOf' chs) su `succeedsLeaving` s context "when stream does not begin with any of specified characters" $ it "signals correct parse error" $ property $ \chs ch s -> ch `notElemi` (chs :: String) ==> do let s' = ch : s prs (oneOf' chs) s' `shouldFailWith` err posI (utok ch) prs' (oneOf' chs) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \chs -> prs (oneOf' (chs :: String)) "" `shouldFailWith` err posI ueof describe "noneOf" $ do context "when stream does not begin with any of specified characters" $ it "parses the character" $ property $ \chs ch s -> ch `notElem` (chs :: String) ==> do let s' = ch : s prs (noneOf chs) s' `shouldParse` ch prs' (noneOf chs) s' `succeedsLeaving` s context "when stream begins with one of specified characters" $ it "signals correct parse error" $ property $ \chs' n s -> do let chs = getNonEmpty chs' ch = chs !! (getNonNegative n `rem` length chs) s' = ch : s prs (noneOf chs) s' `shouldFailWith` err posI (utok ch) prs' (noneOf chs) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \chs -> prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof describe "noneOf'" $ do context "when stream does not begin with any of specified characters" $ it "parses the character" $ property $ \chs ch s -> ch `notElemi` (chs :: String) ==> do let sl = toLower ch : s su = toUpper ch : s prs (noneOf' chs) sl `shouldParse` toLower ch prs (noneOf' chs) su `shouldParse` toUpper ch prs' (noneOf' chs) sl `succeedsLeaving` s prs' (noneOf' chs) su `succeedsLeaving` s context "when stream begins with one of specified characters" $ it "signals correct parse error" $ property $ \chs' n s -> do let chs = getNonEmpty chs' ch = chs !! (getNonNegative n `rem` length chs) s' = ch : s prs (noneOf' chs) s' `shouldFailWith` err posI (utok ch) prs' (noneOf' chs) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \chs -> prs (noneOf' (chs :: String)) "" `shouldFailWith` err posI ueof describe "string" $ do context "when stream is prefixed with given string" $ it "parses the string" $ property $ \str s -> do let s' = str ++ s prs (string str) s' `shouldParse` str prs' (string str) s' `succeedsLeaving` s context "when stream is not prefixed with given string" $ it "signals correct parse error" $ property $ \str s -> not (str `isPrefixOf` s) ==> do let n = length (takeWhile (uncurry (==)) (zip str s)) + 1 common = take n s prs (string str) s `shouldFailWith` err posI (utoks common <> etoks str) describe "string'" $ do context "when stream is prefixed with given string" $ it "parses the string" $ property $ \str s -> forAll (fuzzyCase str) $ \str' -> do let s' = str' ++ s prs (string' str) s' `shouldParse` str' prs' (string' str) s' `succeedsLeaving` s context "when stream is not prefixed with given string" $ it "signals correct parse error" $ property $ \str s -> not (str `isPrefixOfI` s) ==> do let n = length (takeWhile (uncurry casei) (zip str s)) + 1 common = take n s prs (string' str) s `shouldFailWith` err posI (utoks common <> etoks str) ---------------------------------------------------------------------------- -- Helpers checkStrLit :: String -> String -> Parsec Dec String String -> SpecWith () checkStrLit name ts p = do context ("when stream begins with " ++ name) $ it ("parses the " ++ name) $ property $ \s -> do let s' = ts ++ s prs p s' `shouldParse` ts prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $ property $ \ch s -> ch /= head ts ==> do let s' = ch : s prs p s' `shouldFailWith` err posI (utok ch <> etoks ts) prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err posI (ueof <> etoks ts) checkCharPred :: String -> (Char -> Bool) -> Parsec Dec String Char -> SpecWith () checkCharPred name f p = do context ("when stream begins with " ++ name) $ it ("parses the " ++ name) $ property $ \ch s -> f ch ==> do let s' = ch : s prs p s' `shouldParse` ch prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $ property $ \ch s -> not (f ch) ==> do let s' = ch : s prs p s' `shouldFailWith` err posI (utok ch <> elabel name) prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err posI (ueof <> elabel name) checkCharRange :: String -> String -> Parsec Dec String Char -> SpecWith () checkCharRange name tchs p = do forM_ tchs $ \tch -> context ("when stream begins with " ++ showTokens (nes tch)) $ it ("parses the " ++ showTokens (nes tch)) $ property $ \s -> do let s' = tch : s prs p s' `shouldParse` tch prs' p s' `succeedsLeaving` s -- context ("when stream does not begin with " ++ name) $ -- it "signals correct parse error" $ -- property $ \ch s -> ch `notElem` tchs ==> do -- let s' = ch : s -- prs p s' `shouldFailWith` err posI (utok ch <> elabel name) -- prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err posI (ueof <> elabel name) -- | 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 -- | Case-insensitive equality test for characters. casei :: Char -> Char -> Bool casei x y = toUpper x == toUpper y -- | Case-insensitive 'elem'. elemi :: Char -> String -> Bool elemi c = any (casei c) -- | Case-insensitive 'notElem'. notElemi :: Char -> String -> Bool notElemi c = not . elemi c -- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff -- the first list is a prefix of the second with case-insensitive -- comparison. isPrefixOfI :: String -> String -> Bool isPrefixOfI [] _ = True isPrefixOfI _ [] = False isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys megaparsec-5.3.1/tests/Text/Megaparsec/CombinatorSpec.hs0000644000000000000000000002061213123732303021414 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} module Text.Megaparsec.CombinatorSpec (spec) where import Control.Applicative import Data.Char (isLetter, isDigit) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) import Data.Monoid import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Combinator spec :: Spec spec = do describe "between" . it "works" . property $ \pre c n' post -> do let p = between (string pre) (string post) (many (char c)) n = getNonNegative n' b = length (takeWhile (== c) post) z = replicate n c s = pre ++ z ++ post if b > 0 then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s) ( etoks post <> etok c <> (if length post == b then ueof else utoks [post !! b]) ) else prs_ p s `shouldParse` z describe "choice" . it "works" . property $ \cs' s' -> do let cs = getNonEmpty cs' p = choice (char <$> cs) s = [s'] if s' `elem` cs then prs_ p s `shouldParse` s' else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs)) describe "count" . it "works" . property $ \n x' -> do let x = getNonNegative x' p = count n (char 'x') p' = count' n n (char 'x') s = replicate x 'x' prs_ p s `shouldBe` prs_ p' s describe "count'" . it "works" . property $ \m n x' -> do let x = getNonNegative x' p = count' m n (char 'x') s = replicate x 'x' if | n <= 0 || m > n -> if x == 0 then prs_ p s `shouldParse` "" else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof) | m <= x && x <= n -> prs_ p s `shouldParse` s | x < m -> prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x') | otherwise -> prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof) describe "eitherP" . it "works" . property $ \ch -> do let p = eitherP letterChar digitChar s = pure ch if | isLetter ch -> prs_ p s `shouldParse` Left ch | isDigit ch -> prs_ p s `shouldParse` Right ch | otherwise -> prs_ p s `shouldFailWith` err posI (utok ch <> elabel "letter" <> elabel "digit") describe "endBy" . it "works" . property $ \n' c -> do let n = getNonNegative n' p = endBy (char 'a') (char '-') s = intersperse '-' (replicate n 'a') ++ [c] if | c == 'a' && n == 0 -> prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') | c == 'a' -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') | c == '-' && n == 0 -> prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof) | c /= '-' -> prs_ p s `shouldFailWith` err (posN (g n) s) ( utok c <> (if n > 0 then etok '-' else eeof) <> (if n == 0 then etok 'a' else mempty) ) | otherwise -> prs_ p s `shouldParse` replicate n 'a' describe "endBy1" . it "works" . property $ \n' c -> do let n = getNonNegative n' p = endBy1 (char 'a') (char '-') s = intersperse '-' (replicate n 'a') ++ [c] if | c == 'a' && n == 0 -> prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-') | c == 'a' -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-') | c == '-' && n == 0 -> prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a') | c /= '-' -> prs_ p s `shouldFailWith` err (posN (g n) s) ( utok c <> (if n > 0 then etok '-' else mempty) <> (if n == 0 then etok 'a' else mempty) ) | otherwise -> prs_ p s `shouldParse` replicate n 'a' describe "manyTill" . it "works" . property $ \a' b' c' -> do let [a,b,c] = getNonNegative <$> [a',b',c'] p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar s = abcRow a b c if c == 0 then prs_ p s `shouldFailWith` err (posN (a + b) s) (ueof <> etok 'c' <> elabel "letter") else let (pre, post) = break (== 'c') s in prs_ p s `shouldParse` (pre, drop 1 post) describe "someTill" . it "works" . property $ \a' b' c' -> do let [a,b,c] = getNonNegative <$> [a',b',c'] p = (,) <$> someTill letterChar (char 'c') <*> many letterChar s = abcRow a b c if | null s -> prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter") | c == 0 -> prs_ p s `shouldFailWith` err (posN (a + b) s) (ueof <> etok 'c' <> elabel "letter") | s == "c" -> prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter") | head s == 'c' -> prs_ p s `shouldParse` ("c", drop 2 s) | otherwise -> let (pre, post) = break (== 'c') s in prs_ p s `shouldParse` (pre, drop 1 post) describe "option" . it "works" . property $ \d a s -> do let p = option d (string a) p' = fromMaybe d <$> optional (string a) prs_ p s `shouldBe` prs_ p' s describe "sepBy" . it "works" . property $ \n' c' -> do let n = getNonNegative n' c = fromJust c' p = sepBy (char 'a') (char '-') s = intersperse '-' (replicate n 'a') ++ maybeToList c' if | isNothing c' -> prs_ p s `shouldParse` replicate n 'a' | c == 'a' && n == 0 -> prs_ p s `shouldParse` "a" | n == 0 -> prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof) | c == '-' -> prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a') | otherwise -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) describe "sepBy1" . it "works" . property $ \n' c' -> do let n = getNonNegative n' c = fromJust c' p = sepBy1 (char 'a') (char '-') s = intersperse '-' (replicate n 'a') ++ maybeToList c' if | isNothing c' && n >= 1 -> prs_ p s `shouldParse` replicate n 'a' | isNothing c' -> prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') | c == 'a' && n == 0 -> prs_ p s `shouldParse` "a" | n == 0 -> prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') | c == '-' -> prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a') | otherwise -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) describe "sepEndBy" . it "works" . property $ \n' c' -> do let n = getNonNegative n' c = fromJust c' p = sepEndBy (char 'a') (char '-') a = replicate n 'a' s = intersperse '-' (replicate n 'a') ++ maybeToList c' if | isNothing c' -> prs_ p s `shouldParse` a | c == 'a' && n == 0 -> prs_ p s `shouldParse` "a" | n == 0 -> prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof) | c == '-' -> prs_ p s `shouldParse` a | otherwise -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) describe "sepEndBy1" . it "works" . property $ \n' c' -> do let n = getNonNegative n' c = fromJust c' p = sepEndBy1 (char 'a') (char '-') a = replicate n 'a' s = intersperse '-' (replicate n 'a') ++ maybeToList c' if | isNothing c' && n >= 1 -> prs_ p s `shouldParse` a | isNothing c' -> prs_ p s `shouldFailWith` err posI (ueof <> etok 'a') | c == 'a' && n == 0 -> prs_ p s `shouldParse` "a" | n == 0 -> prs_ p s `shouldFailWith` err posI (utok c <> etok 'a') | c == '-' -> prs_ p s `shouldParse` a | otherwise -> prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof) describe "skipMany" . it "works" . property $ \c n' a -> do let p = skipMany (char c) *> string a n = getNonNegative n' p' = many (char c) >> string a s = replicate n c ++ a prs_ p s `shouldBe` prs_ p' s describe "skipSome" . it "works" . property $ \c n' a -> do let p = skipSome (char c) *> string a n = getNonNegative n' p' = some (char c) >> string a s = replicate n c ++ a prs_ p s `shouldBe` prs_ p' s ---------------------------------------------------------------------------- -- Helpers g :: Int -> Int g x = x + if x > 0 then x - 1 else 0 megaparsec-5.3.1/tests/Text/Megaparsec/ErrorSpec.hs0000644000000000000000000001642213123731704020420 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS -fno-warn-orphans #-} module Text.Megaparsec.ErrorSpec (spec) where import Data.Char (isControl, isSpace) import Data.Function (on) import Data.List (isInfixOf, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid import Data.Set (Set) import Test.Hspec import Test.QuickCheck import Text.Megaparsec.Error import Text.Megaparsec.Pos import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S import qualified Data.Set as E #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable, all) import Prelude hiding (all) #else import Control.Exception (Exception (..)) #endif type PE = ParseError Char Dec spec :: Spec spec = do describe "Semigroup instance of ParseError" $ it "associativity" $ property $ \x y z -> (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE) describe "Monoid instance of ParseError" $ do it "left identity" $ property $ \x -> mempty <> x === (x :: PE) it "right identity" $ property $ \x -> x <> mempty === (x :: PE) it "associativity" $ property $ \x y z -> (x <> y) <> z === (x <> (y <> z) :: PE) describe "Read and Show instances of ParseError" $ it "printed representation of ParseError can be read back" $ property $ \x -> read (show x) === (x :: PE) describe "error merging with (<>)" $ do it "selects greater source position" $ property $ \x y -> errorPos (x <> y :: PE) === max (errorPos x) (errorPos y) it "merges unexpected items correctly" $ property (checkMergedItems errorUnexpected) it "merges expected items correctly" $ property (checkMergedItems errorExpected) it "merges custom items correctly" $ property (checkMergedItems errorCustom) describe "showTokens (Char instance)" $ do let f x y = showTokens (NE.fromList x) `shouldBe` y it "shows CRLF newline correctly" (f "\r\n" "crlf newline") it "shows null byte correctly" (f "\NUL" "null (control character)") it "shows start of heading correctly" (f "\SOH" "start of heading (control character)") it "shows start of text correctly" (f "\STX" "start of text (control character)") it "shows end of text correctly" (f "\ETX" "end of text (control character)") it "shows end of transmission correctly" (f "\EOT" "end of transmission (control character)") it "shows enquiry correctly" (f "\ENQ" "enquiry (control character)") it "shows acknowledge correctly" (f "\ACK" "acknowledge (control character)") it "shows bell correctly" (f "\BEL" "bell (control character)") it "shows backspace correctly" (f "\BS" "backspace") it "shows tab correctly" (f "\t" "tab") it "shows newline correctly" (f "\n" "newline") it "shows vertical tab correctly" (f "\v" "vertical tab") it "shows form feed correctly" (f "\f" "form feed (control character)") it "shows carriage return correctly" (f "\r" "carriage return") it "shows shift out correctly" (f "\SO" "shift out (control character)") it "shows shift in correctly" (f "\SI" "shift in (control character)") it "shows data link escape correctly" (f "\DLE" "data link escape (control character)") it "shows device control one correctly" (f "\DC1" "device control one (control character)") it "shows device control two correctly" (f "\DC2" "device control two (control character)") it "shows device control three correctly" (f "\DC3" "device control three (control character)") it "shows device control four correctly" (f "\DC4" "device control four (control character)") it "shows negative acknowledge correctly" (f "\NAK" "negative acknowledge (control character)") it "shows synchronous idle correctly" (f "\SYN" "synchronous idle (control character)") it "shows end of transmission block correctly" (f "\ETB" "end of transmission block (control character)") it "shows cancel correctly" (f "\CAN" "cancel (control character)") it "shows end of medium correctly" (f "\EM" "end of medium (control character)") it "shows substitute correctly" (f "\SUB" "substitute (control character)") it "shows escape correctly" (f "\ESC" "escape (control character)") it "shows file separator correctly" (f "\FS" "file separator (control character)") it "shows group separator correctly" (f "\GS" "group separator (control character)") it "shows record separator correctly" (f "\RS" "record separator (control character)") it "shows unit separator correctly" (f "\US" "unit separator (control character)") it "shows delete correctly" (f "\DEL" "delete (control character)") it "shows space correctly" (f " " "space") it "shows non-breaking space correctly" (f "\160" "non-breaking space") it "shows other single characters in single quotes" $ property $ \ch -> not (isControl ch) && not (isSpace ch) ==> showTokens (ch :| []) === ['\'',ch,'\''] it "shows strings in double quotes" $ property $ \str -> (length str > 1) && (str /= "\r\n") ==> showTokens (NE.fromList str) === ("\"" ++ str ++"\"") describe "parseErrorPretty" $ do it "shows unknown ParseError correctly" $ parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n" it "result always ends with a newline" $ property $ \x -> parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`) it "result contains representation of source pos stack" $ property (contains errorPos sourcePosPretty) it "result contains representation of unexpected items" $ property (contains errorUnexpected showErrorComponent) it "result contains representation of expected items" $ property (contains errorExpected showErrorComponent) it "result contains representation of custom items" $ property (contains errorCustom showErrorComponent) describe "sourcePosStackPretty" $ it "result never ends with a newline " $ property $ \x -> let pos = errorPos (x :: PE) in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`) describe "parseErrorTextPretty" $ do it "shows unknown ParseError correctly" $ parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n" it "result always ends with a newline" $ property $ \x -> parseErrorTextPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`) #if MIN_VERSION_base(4,8,0) describe "displayException" $ it "produces the same result as parseErrorPretty" $ property $ \x -> displayException x `shouldBe` parseErrorPretty (x :: PE) #endif ---------------------------------------------------------------------------- -- Helpers checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property checkMergedItems f e1 e2 = f (e1 <> e2) === r where r = case (compare `on` errorPos) e1 e2 of LT -> f e2 EQ -> (E.union `on` f) e1 e2 GT -> f e1 contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property contains g r e = property (all f (g e)) where rendered = parseErrorPretty e f x = r x `isInfixOf` rendered megaparsec-5.3.1/tests/Text/Megaparsec/ExprSpec.hs0000644000000000000000000001243713123732303020243 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.ExprSpec (spec) where import Control.Applicative (some, (<|>)) import Data.Monoid ((<>)) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Combinator import Text.Megaparsec.Expr import Text.Megaparsec.Prim #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) #endif spec :: Spec spec = describe "makeExprParser" $ do context "when given valid rendered AST" $ it "can parse it back" $ property $ \node -> do let s = showNode node prs expr s `shouldParse` node prs' expr s `succeedsLeaving` "" context "when stream in empty" $ it "signals correct parse error" $ prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term") context "when term is missing" $ it "signals correct parse error" $ do let p = expr <* eof n = 1 :: Integer prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term") prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term") prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term") context "operator is missing" $ it "signals correct parse error" $ property $ \a b -> do let p = expr <* eof a' = inParens a n = length a' + 1 s = a' ++ " " ++ inParens b c = s !! n if c == '-' then prs p s `shouldParse` Sub a b else prs p s `shouldFailWith` err (posN n s) (utok c <> eeof <> elabel "operator") -- 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 a 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)] ] megaparsec-5.3.1/tests/Text/Megaparsec/LexerSpec.hs0000644000000000000000000004507013123732303020403 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.LexerSpec (spec) where import Control.Applicative import Control.Monad (void) import Data.Char hiding (ord) import Data.List (isInfixOf) import Data.Maybe import Data.Monoid ((<>)) import Data.Scientific (fromFloatDigits) import Numeric (showInt, showHex, showOct) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Error import Text.Megaparsec.Lexer import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String import qualified Text.Megaparsec.Char as C spec :: Spec spec = do describe "space" $ it "consumes any sort of white space" $ property $ forAll mkWhiteSpace $ \s -> do prs scn s `shouldParse` () prs' scn s `succeedsLeaving` "" describe "symbol" $ context "when stream begins with the symbol" $ it "parses the symbol and trailing whitespace" $ property $ forAll mkSymbol $ \s -> do let p = symbol scn y y = takeWhile (not . isSpace) s prs p s `shouldParse` y prs' p s `succeedsLeaving` "" describe "symbol'" $ context "when stream begins with the symbol" $ it "parses the symbol and trailing whitespace" $ property $ forAll mkSymbol $ \s -> do let p = symbol' scn (toUpper <$> y) y = takeWhile (not . isSpace) s prs p s `shouldParse` y prs' p s `succeedsLeaving` "" describe "skipLineComment" $ context "when there is no newline at the end of line" $ it "is picked up successfully" $ do let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof s = " // this line comment doesn't have a newline at the end " prs p s `shouldParse` () prs' p s `succeedsLeaving` "" describe "skipBlockCommentNested" $ context "when it runs into nested block comments" $ it "parses them all right" $ do let p = space (void C.spaceChar) empty (skipBlockCommentNested "/*" "*/") <* eof s = " /* foo bar /* baz */ quux */ " prs p s `shouldParse` () prs' p s `succeedsLeaving` "" describe "indentLevel" $ it "returns current indentation level (column)" $ property $ \pos -> do let p = setPosition pos *> indentLevel prs p "" `shouldParse` sourceColumn pos describe "incorrectIndent" $ it "signals correct parse error" $ property $ \ord ref actual -> do let p :: Parser () p = incorrectIndent ord ref actual prs p "" `shouldFailWith` err posI (ii ord ref actual) describe "indentGuard" $ it "works as intended" $ property $ \n -> do let mki = mkIndent sbla (getSmall $ getNonNegative n) forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) fragments = [l0,l1,l2] g x = sum (length <$> take x fragments) s = concat fragments p = ip GT pos1 >>= \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn ip = indentGuard scn sp = void (symbol sc sbla <* C.eol) if | col0 <= pos1 -> prs p s `shouldFailWith` err posI (ii GT pos1 col0) | col1 /= col0 -> prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1) | col2 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) | otherwise -> prs p s `shouldParse` () describe "nonIdented" $ it "works as intended" $ property $ forAll (mkIndent sbla 0) $ \s -> do let p = nonIndented scn (symbol scn sbla) i = getIndent s if i == 0 then prs p s `shouldParse` sbla else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s)) describe "indentBlock" $ do it "works as indented" $ property $ \mn'' -> do let mkBlock = do l0 <- mkIndent sbla 0 l1 <- mkIndent sblb ib l2 <- mkIndent sblc (ib + 2) l3 <- mkIndent sblb ib l4 <- mkIndent' sblc (ib + 2) return (l0,l1,l2,l3,l4) ib = fromMaybe 2 mn' mn' = getSmall . getPositive <$> mn'' mn = unsafePos . fromIntegral <$> mn' forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do let (col0, col1, col2, col3, col4) = (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4) fragments = [l0,l1,l2,l3,l4] g x = sum (length <$> take x fragments) s = concat fragments p = lvla <* eof lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb lvlc = indentBlock scn $ IndentNone sblc <$ b sblc b = symbol sc l x = return . (x,) ib' = unsafePos (fromIntegral ib) if | col1 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof) | isJust mn && col1 /= ib' -> prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1) | col2 <= col1 -> prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col1 col2) | col3 == col2 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc <> eeof) | col3 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof) | col3 < col1 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3) | col3 > col1 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3) | col4 <= col3 -> prs p s `shouldFailWith` err (posN (getIndent l4 + g 4) s) (ii GT col3 col4) | otherwise -> prs p s `shouldParse` (sbla, [(sblb, [sblc]), (sblb, [sblc])]) it "IndentMany works as intended (newline at the end)" $ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do let p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb b = symbol sc l x = return . (x,) prs p s `shouldParse` (sbla, []) prs' p s `succeedsLeaving` "" it "IndentMany works as intended (eof)" $ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do let p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb b = symbol sc l x = return . (x,) prs p s `shouldParse` (sbla, []) prs' p s `succeedsLeaving` "" it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do let p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb b = symbol sc l x = return . (x,) s = "aaa\n bbb\n " prs p s `shouldParse` (sbla, [sblb]) prs' p s `succeedsLeaving` "" it "works with many and both IndentMany and IndentNone" $ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla p2 = indentBlock scn $ IndentNone sbla <$ b sbla lvlb = b sblb b = symbol sc l x = return . (x,) prs (many p1) s `shouldParse` [(sbla, [])] prs (many p2) s `shouldParse` [sbla] prs' (many p1) s `succeedsLeaving` "" prs' (many p2) s `succeedsLeaving` "" describe "lineFold" $ it "works as intended" $ property $ do let mkFold = do l0 <- mkInterspace sbla 0 l1 <- mkInterspace sblb 1 l2 <- mkInterspace sblc 1 return (l0,l1,l2) forAll mkFold $ \(l0,l1,l2) -> do let p = lineFold scn $ \sc' -> do a <- symbol sc' sbla b <- symbol sc' sblb c <- symbol scn sblc return (a, b, c) getEnd x = last x == '\n' fragments = [l0,l1,l2] g x = sum (length <$> take x fragments) s = concat fragments (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) (end0, end1) = (getEnd l0, getEnd l1) if | end0 && col1 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii GT col0 col1) | end1 && col2 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) describe "charLiteral" $ do context "when stream begins with a literal character" $ it "parses it" $ property $ \ch -> do let p = charLiteral s = showLitChar ch "" prs p s `shouldParse` ch prs' p s `succeedsLeaving` "" context "when stream does not begin with a literal character" $ it "signals correct parse error" $ do let p = charLiteral s = "\\" prs p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character") prs' p s `failsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ do let p = charLiteral prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character") describe "integer" $ do context "when stream begins with decimal digits" $ it "they are parsed as an integer" $ property $ \n' -> do let p = integer n = getNonNegative n' s = showInt n "" prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with decimal digits" $ it "signals correct parse error" $ property $ \a as -> not (isDigit a) ==> do let p = integer s = a : as prs p s `shouldFailWith` err posI (utok a <> elabel "integer") context "when stream is empty" $ it "signals correct parse error" $ prs integer "" `shouldFailWith` err posI (ueof <> elabel "integer") describe "decimal" $ do context "when stream begins with decimal digits" $ it "they are parsed as an integer" $ property $ \n' -> do let p = decimal n = getNonNegative n' s = showInt n "" prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with decimal digits" $ it "signals correct parse error" $ property $ \a as -> not (isDigit a) ==> do let p = decimal s = a : as prs p s `shouldFailWith` err posI (utok a <> elabel "decimal integer") context "when stream is empty" $ it "signals correct parse error" $ prs decimal "" `shouldFailWith` err posI (ueof <> elabel "decimal integer") describe "hexadecimal" $ do context "when stream begins with hexadecimal digits" $ it "they are parsed as an integer" $ property $ \n' -> do let p = hexadecimal n = getNonNegative n' s = showHex n "" prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with hexadecimal digits" $ it "signals correct parse error" $ property $ \a as -> not (isHexDigit a) ==> do let p = hexadecimal s = a : as prs p s `shouldFailWith` err posI (utok a <> elabel "hexadecimal integer") context "when stream is empty" $ it "signals correct parse error" $ prs hexadecimal "" `shouldFailWith` err posI (ueof <> elabel "hexadecimal integer") describe "octal" $ do context "when stream begins with octal digits" $ it "they are parsed as an integer" $ property $ \n' -> do let p = octal n = getNonNegative n' s = showOct n "" prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with octal digits" $ it "signals correct parse error" $ property $ \a as -> not (isOctDigit a) ==> do let p = octal s = a : as prs p s `shouldFailWith` err posI (utok a <> elabel "octal integer") context "when stream is empty" $ it "signals correct parse error" $ prs octal "" `shouldFailWith` err posI (ueof <> elabel "octal integer") describe "float" $ do context "when stream begins with a float" $ it "parses it" $ property $ \n' -> do let p = float n = getNonNegative n' s = show n prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with a float" $ it "signals correct parse error" $ property $ \a as -> not (isDigit a) ==> do let p = float s = a : as prs p s `shouldFailWith` err posI (utok a <> elabel "floating point number") prs' p s `failsLeaving` s context "when stream begins with a decimal number" $ it "signals correct parse error" $ property $ \n' -> do let p = float n = getNonNegative n' s = show (n :: Integer) prs p s `shouldFailWith` err (posN (length s) s) (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit") prs' p s `failsLeaving` "" context "when stream is empty" $ it "signals correct parse error" $ prs float "" `shouldFailWith` err posI (ueof <> elabel "floating point number") context "when there is float with exponent without explicit sign" $ it "parses it all right" $ do let p = float s = "123e3" prs p s `shouldParse` 123e3 prs' p s `succeedsLeaving` "" describe "number" $ do context "when stream begins with a number" $ it "parses it" $ property $ \n' -> do let p = number s = either (show . getNonNegative) (show . getNonNegative) (n' :: Either (NonNegative Integer) (NonNegative Double)) prs p s `shouldParse` case n' of Left x -> fromIntegral (getNonNegative x) Right x -> fromFloatDigits (getNonNegative x) prs' p s `succeedsLeaving` "" context "when stream is empty" $ it "signals correct parse error" $ prs number "" `shouldFailWith` err posI (ueof <> elabel "number") describe "signed" $ do context "with integer" $ it "parses signed integers" $ property $ \n -> do let p = signed (hidden C.space) integer s = show n prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with float" $ it "parses signed floats" $ property $ \n -> do let p = signed (hidden C.space) float s = show n prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with number" $ it "parses singed numbers" $ property $ \n -> do let p = signed (hidden C.space) number s = either show show (n :: Either Integer Double) prs p s `shouldParse` case n of Left x -> fromIntegral x Right x -> fromFloatDigits x context "when number is prefixed with plus sign" $ it "parses the number" $ property $ \n' -> do let p = signed (hidden C.space) integer n = getNonNegative n' s = '+' : show n prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when number is prefixed with white space" $ it "signals correct parse error" $ property $ \n -> do let p = signed (hidden C.space) integer s = ' ' : show (n :: Integer) prs p s `shouldFailWith` err posI (utok ' ' <> etok '+' <> etok '-' <> elabel "integer") prs' p s `failsLeaving` s context "when there is white space between sign and digits" $ it "parses it all right" $ do let p = signed (hidden C.space) integer s = "- 123" prs p s `shouldParse` (-123) prs' p s `succeedsLeaving` "" ---------------------------------------------------------------------------- -- Helpers mkWhiteSpace :: Gen String mkWhiteSpace = concat <$> listOf whiteUnit where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock] mkWhiteSpaceNl :: Gen String mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n" mkSymbol :: Gen String mkSymbol = (++) <$> symbolName <*> whiteChars mkInterspace :: String -> Int -> Gen String mkInterspace x n = oneof [si, mkIndent x n] where si = (++ x) <$> listOf (elements " \t") mkIndent :: String -> Int -> Gen String mkIndent x n = (++) <$> mkIndent' x n <*> eol where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))] mkIndent' :: String -> Int -> Gen String mkIndent' x n = concat <$> sequence [spc, sym, tra] where spc = frequency [(5, vectorOf n itm), (1, listOf itm)] tra = listOf itm itm = elements " \t" sym = return x whiteChars :: Gen String whiteChars = listOf (elements "\t\n ") whiteLine :: Gen String whiteLine = commentOut <$> arbitrary `suchThat` goodEnough where commentOut x = "//" ++ x ++ "\n" goodEnough x = '\n' `notElem` x whiteBlock :: Gen String whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough where commentOut x = "/*" ++ x ++ "*/" goodEnough x = not $ "*/" `isInfixOf` x symbolName :: Gen String symbolName = listOf $ arbitrary `suchThat` isAlphaNum sc :: Parser () sc = space (void $ C.oneOf " \t") empty empty scn :: Parser () scn = space (void C.spaceChar) l b where l = skipLineComment "//" b = skipBlockComment "/*" "*/" getIndent :: String -> Int getIndent = length . takeWhile isSpace getCol :: String -> Pos getCol x = sourceColumn . updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x sbla, sblb, sblc :: String sbla = "aaa" sblb = "bbb" sblc = "ccc" ii :: Ordering -> Pos -> Pos -> EC Char Dec ii ord ref actual = cstm (DecIndentation ord ref actual) megaparsec-5.3.1/tests/Text/Megaparsec/PermSpec.hs0000644000000000000000000000673213116223306020231 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} module Text.Megaparsec.PermSpec (spec) where import Control.Applicative import Data.List (nub, elemIndices) import Data.Monoid import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Char import Text.Megaparsec.Lexer (integer) import Text.Megaparsec.Perm 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 spec :: Spec spec = do describe "(<$$>)" $ do context "when supplied parser succeeds" $ it "returns value returned by the parser" $ property $ \n -> do let p = makePermParser (succ <$$> pure (n :: Integer)) prs p "" `shouldParse` succ n context "when supplied parser fails" $ it "signals correct parse error" $ do let p = makePermParser (succ <$$> integer) prs p "" `shouldFailWith` err posI (ueof <> elabel "integer") describe "(<$?>)" $ do context "when supplied parser succeeds" $ it "returns value returned by the parser" $ property $ \n m -> do let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer))) prs p "" `shouldParse` succ m context "when supplied parser fails" $ it "returns the default value" $ property $ \n -> do let p = makePermParser (succ <$?> (n :: Integer, fail "foo")) prs p "" `shouldParse` succ n context "when stream in empty" $ it "returns the default value" $ property $ \n -> do let p = makePermParser (succ <$?> (n :: Integer, integer)) prs p "" `shouldParse` succ n describe "makeExprParser" $ it "works" $ property $ \a' c' v -> do let (a,b,c) = getChars v p = makePermParser ((,,) <$?> (a' :: String, some (char a)) <||> char b <|?> (c', char c)) bis = elemIndices b s preb = take (bis !! 1) s cis = elemIndices c s prec = take (cis !! 1) s s = getInput v if | length bis > 1 && (length cis <= 1 || head bis < head cis) -> prs_ p s `shouldFailWith` err (posN (bis !! 1) s) ( utok b <> eeof <> (if a `elem` preb then mempty else etok a) <> (if c `elem` preb then mempty else etok c) ) | length cis > 1 -> prs_ p s `shouldFailWith` err (posN (cis !! 1) s) ( utok c <> (if a `elem` prec then mempty else etok a) <> (if b `elem` prec then eeof else etok b) ) | b `notElem` s -> prs_ p s `shouldFailWith` err (posN (length s) s) ( ueof <> etok b <> (if a `notElem` s || last s == a then etok a else mempty) <> (if c `elem` s then mempty else etok c) ) | otherwise -> prs_ p s `shouldParse` ( if a `elem` s then filter (== a) s else a' , b , if c `elem` s then c else c' ) megaparsec-5.3.1/tests/Text/Megaparsec/PosSpec.hs0000644000000000000000000000651613116223306020067 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS -fno-warn-orphans #-} module Text.Megaparsec.PosSpec (spec) where import Data.Function (on) import Data.List (isInfixOf) import Data.Semigroup ((<>)) import Test.Hspec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec.Pos #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif spec :: Spec spec = do describe "mkPos" $ do context "when the argument is 0" $ it "throws InvalidPosException" $ mkPos (0 :: Word) `shouldThrow` (== InvalidPosException) context "when the argument is not 0" $ it "returns Pos with the given value" $ property $ \n -> (n > 0) ==> (mkPos n >>= shouldBe n . unPos) describe "unsafePos" $ context "when the argument is a positive integer" $ it "returns Pos with the given value" $ property $ \n -> (n > 0) ==> (unPos (unsafePos n) === n) describe "Read and Show instances of Pos" $ it "printed representation of Pos is isomorphic to its value" $ property $ \x -> read (show x) === (x :: Pos) describe "Ord instance of Pos" $ it "works just like Ord instance of underlying Word" $ property $ \x y -> compare x y === (compare `on` unPos) x y describe "Semigroup instance of Pos" $ it "works like addition" $ property $ \x y -> x <> y === unsafePos (unPos x + unPos y) .&&. unPos (x <> y) === unPos x + unPos y describe "initialPos" $ it "consturcts initial position correctly" $ property $ \path -> let x = initialPos path in sourceName x === path .&&. sourceLine x === unsafePos 1 .&&. sourceColumn x === unsafePos 1 describe "Read and Show instances of SourcePos" $ it "printed representation of SourcePos in isomorphic to its value" $ property $ \x -> read (show x) === (x :: SourcePos) describe "sourcePosPretty" $ do it "displays file name" $ property $ \x -> sourceName x `isInfixOf` sourcePosPretty x it "displays line number" $ property $ \x -> (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x it "displays column number" $ property $ \x -> (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x describe "defaultUpdatePos" $ do it "returns actual position unchanged" $ property $ \w pos ch -> fst (defaultUpdatePos w pos ch) === pos it "does not change file name" $ property $ \w pos ch -> (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos context "when given newline character" $ it "increments line number" $ property $ \w pos -> (sourceLine . snd) (defaultUpdatePos w pos '\n') === (sourceLine pos <> pos1) context "when given tab character" $ it "shits column number to next tab position" $ property $ \w pos -> let c = sourceColumn pos c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t') in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0) context "when given character other than newline or tab" $ it "increments column number by one" $ property $ \w pos ch -> (ch /= '\n' && ch /= '\t') ==> (sourceColumn . snd) (defaultUpdatePos w pos ch) === (sourceColumn pos <> pos1) megaparsec-5.3.1/tests/Text/Megaparsec/PrimSpec.hs0000644000000000000000000020160513123733062020234 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-orphans #-} module Text.Megaparsec.PrimSpec (spec) where import Control.Applicative import Control.Monad.Cont import Control.Monad.Except import Control.Monad.Identity import Control.Monad.Reader import Data.Char (toUpper, chr) import Data.Foldable (asum, concat) import Data.Function (on) import Data.List (isPrefixOf, foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, listToMaybe, isJust) import Data.Monoid import Data.Proxy import Data.Word (Word8) import Prelude hiding (span, concat) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck hiding (label) import Text.Megaparsec.Char import Text.Megaparsec.Combinator import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String import qualified Control.Monad.RWS.Lazy as L import qualified Control.Monad.RWS.Strict as S import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L import qualified Control.Monad.Writer.Strict as S import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as G import qualified Data.Set as E import qualified Data.Text as T import qualified Data.Text.Lazy as TL #if !MIN_VERSION_QuickCheck(2,8,2) instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where arbitrary = E.fromList <$> arbitrary shrink = fmap E.fromList . shrink . E.toList #endif spec :: Spec spec = do describe "non-String instances of Stream" $ do context "lazy ByteString" $ do it "unconses correctly" $ property $ \ch' n -> do let p = many (char ch) :: Parsec Dec BL.ByteString String s = replicate (getNonNegative n) ch ch = byteToChar ch' parse p "" (BL.pack s) `shouldParse` s it "updates position like with String" $ property $ \w pos ch -> updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe` updatePos (Proxy :: Proxy String) w pos ch context "strict ByteString" $ do it "unconses correctly" $ property $ \ch' n -> do let p = many (char ch) :: Parsec Dec B.ByteString String s = replicate (getNonNegative n) ch ch = byteToChar ch' parse p "" (B.pack s) `shouldParse` s it "updates position like with String" $ property $ \w pos ch -> updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe` updatePos (Proxy :: Proxy String) w pos ch context "lazy Text" $ do it "unconses correctly" $ property $ \ch n -> do let p = many (char ch) :: Parsec Dec TL.Text String s = replicate (getNonNegative n) ch parse p "" (TL.pack s) `shouldParse` s it "updates position like with String" $ property $ \w pos ch -> updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe` updatePos (Proxy :: Proxy String) w pos ch context "strict Text" $ do it "unconses correctly" $ property $ \ch n -> do let p = many (char ch) :: Parsec Dec T.Text String s = replicate (getNonNegative n) ch parse p "" (T.pack s) `shouldParse` s it "updates position like with String" $ property $ \w pos ch -> updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe` updatePos (Proxy :: Proxy String) w pos ch describe "position in custom stream" $ do describe "eof" $ it "updates position in stream correctly" $ property $ \st -> (not . null . stateInput) st ==> do let p = eof :: CustomParser () h = head (stateInput st) apos = let (_:|z) = statePos st in spanStart h :| z runParser' p st `shouldBe` ( st { statePos = apos } , Left (err apos $ utok h <> eeof) ) describe "token" $ do context "when input stream is empty" $ it "signals correct parse error" $ property $ \st'@State {..} span -> do let p = pSpan span st = (st' :: State [Span]) { stateInput = [] } runParser' p st `shouldBe` ( st , Left (err statePos $ ueof <> etok span) ) context "when head of stream matches" $ it "updates parser state correctly" $ property $ \st'@State {..} span -> do let p = pSpan span st = st' { stateInput = span : stateInput } npos = spanEnd span :| NE.tail statePos runParser' p st `shouldBe` ( st { statePos = npos , stateTokensProcessed = stateTokensProcessed + 1 , stateInput = stateInput } , Right span ) context "when head of stream does not match" $ do let checkIt s span = let ms = listToMaybe s in isJust ms && (spanBody <$> ms) /= Just (spanBody span) it "signals correct parse error" $ property $ \st@State {..} span -> checkIt stateInput span ==> do let p = pSpan span h = head stateInput apos = spanStart h :| NE.tail statePos runParser' p st `shouldBe` ( st { statePos = apos } , Left (err apos $ utok h <> etok span)) describe "tokens" $ it "updates position is stream correctly" $ property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do let p = tokens compareTokens ts :: CustomParser [Span] compareTokens x y = spanBody x == spanBody y updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth il = length . takeWhile id $ zipWith compareTokens stateInput ts tl = length ts consumed = take il stateInput (apos, npos) = let (pos:|z) = statePos in ( spanStart (head stateInput) :| z , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) if | null ts -> runParser' p st `shouldBe` (st, Right []) | null stateInput -> runParser' p st `shouldBe` ( st , Left (err statePos $ ueof <> etoks ts) ) | il == tl -> runParser' p st `shouldBe` ( st { statePos = npos , stateTokensProcessed = stateTokensProcessed + fromIntegral tl , stateInput = drop (length ts) stateInput } , Right consumed ) | otherwise -> runParser' p st `shouldBe` ( st { statePos = apos } , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) ) describe "getNextTokenPosition" $ do context "when input stream is empty" $ it "returns Nothing" $ property $ \st' -> do let p :: CustomParser (Maybe SourcePos) p = getNextTokenPosition st = (st' :: State [Span]) { stateInput = [] } runParser' p st `shouldBe` (st, Right Nothing) context "when input stream is not empty" $ it "return the position of start of the next token" $ property $ \st' h -> do let p :: CustomParser (Maybe SourcePos) p = getNextTokenPosition st = st' { stateInput = h : stateInput st' } runParser' p st `shouldBe` (st, (Right . Just . spanStart) h) describe "ParsecT Semigroup instance" $ it "the associative operation works" $ property $ \a b -> do let p = pure [a] G.<> pure [b] prs p "" `shouldParse` ([a,b] :: [Int]) describe "ParsecT Monoid instance" $ do it "mempty works" $ do let p = mempty prs p "" `shouldParse` ([] :: [Int]) it "mappend works" $ property $ \a b -> do let p = pure [a] `mappend` pure [b] prs p "" `shouldParse` ([a,b] :: [Int]) describe "ParsecT Functor instance" $ do it "obeys identity law" $ property $ \n -> prs (fmap id (pure (n :: Int))) "" === prs (id (pure n)) "" it "obeys composition law" $ property $ \n m t -> let f = (+ m) g = (* t) in prs (fmap (f . g) (pure (n :: Int))) "" === prs ((fmap f . fmap g) (pure n)) "" describe "ParsecT Applicative instance" $ do it "obeys identity law" $ property $ \n -> prs (pure id <*> pure (n :: Int)) "" === prs (pure n) "" it "obeys composition law" $ property $ \n m t -> let u = pure (+ m) v = pure (* t) w = pure (n :: Int) in prs (pure (.) <*> u <*> v <*> w) "" === prs (u <*> (v <*> w)) "" it "obeys homomorphism law" $ property $ \x m -> let f = (+ m) in prs (pure f <*> pure (x :: Int)) "" === prs (pure (f x)) "" it "obeys interchange law" $ property $ \n y -> let u = pure (+ n) in prs (u <*> pure (y :: Int)) "" === prs (pure ($ y) <*> u) "" describe "(<*>)" $ context "when first parser succeeds without consuming" $ context "when second parser fails consuming input" $ it "fails consuming input" $ do let p = m <*> n m = return (\x -> 'a' : x) n = string "bc" <* empty s = "bc" prs p s `shouldFailWith` err (posN (4 :: Int) s) mempty prs' p s `failsLeaving` "" describe "(*>)" $ it "works correctly" $ property $ \n m -> let u = pure (+ (m :: Int)) v = pure (n :: Int) in prs (u *> v) "" === prs (pure (const id) <*> u <*> v) "" describe "(<*)" $ it "works correctly" $ property $ \n m -> let u = pure (m :: Int) v = pure (+ (n :: Int)) in prs (u <* v) "" === prs (pure const <*> u <*> v) "" describe "ParsecT Alternative instance" $ do describe "empty" $ it "always fails" $ property $ \n -> prs (empty <|> pure n) "" `shouldParse` (n :: Integer) describe "(<|>)" $ do context "with two strings" $ do context "stream begins with the first string" $ it "parses the string" $ property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do let s' = s0 ++ s p = string s0 <|> string s1 prs p s' `shouldParse` s0 prs' p s' `succeedsLeaving` s context "stream begins with the second string" $ it "parses the string" $ property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do let s' = s1 ++ s p = string s0 <|> string s1 prs p s' `shouldParse` s1 prs' p s' `succeedsLeaving` s context "when stream does not begin with either string" $ it "signals correct error message" $ property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do let p = string s0 <|> string s1 z0' = toFirstMismatch (==) s0 s z1' = toFirstMismatch (==) s1 s prs p s `shouldFailWith` err posI (etoks s0 <> etoks s1 <> (if null s then ueof else mempty) <> (if null z0' then mempty else utoks z0') <> (if null z1' then mempty else utoks z1')) context "with two complex parsers" $ do context "when stream begins with matching character" $ it "parses it" $ property $ \a b -> a /= b ==> do let p = char a <|> (char b *> char a) s = [a] prs p s `shouldParse` a prs' p s `succeedsLeaving` "" context "when stream begins with only one matching character" $ it "signals correct parse error" $ property $ \a b c -> a /= b && a /= c ==> do let p = char a <|> (char b *> char a) s = [b,c] prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a) prs' p s `failsLeaving` [c] context "when stream begins with not matching character" $ it "signals correct parse error" $ property $ \a b c -> a /= b && a /= c && b /= c ==> do let p = char a <|> (char b *> char a) s = [c,b] prs p s `shouldFailWith` err posI (utok c <> etok a <> etok b) prs' p s `failsLeaving` s context "when stream is emtpy" $ it "signals correct parse error" $ property $ \a b -> do let p = char a <|> (char b *> char a) prs p "" `shouldFailWith` err posI (ueof <> etok a <> etok b) it "associativity of fold over alternatives should not matter" $ do let p = asum [empty, string ">>>", empty, return "foo"] "bar" p' = bsum [empty, string ">>>", empty, return "foo"] "bar" bsum = foldl (<|>) empty s = ">>" prs p s `shouldBe` prs p' s describe "many" $ do context "when stream begins with things argument of many parses" $ it "they are parsed" $ property $ \a' b' c' -> do let [a,b,c] = getNonNegative <$> [a',b',c'] p = many (char 'a') s = abcRow a b c prs p s `shouldParse` replicate a 'a' prs' p s `succeedsLeaving` drop a s context "when stream does not begin with thing argument of many parses" $ it "does nothing" $ property $ \a' b' c' -> do let [a,b,c] = getNonNegative <$> [a',b',c'] p = many (char 'd') s = abcRow a b c prs p s `shouldParse` "" prs' p s `succeedsLeaving` s context "when stream is empty" $ it "succeeds parsing nothing" $ do let p = many (char 'a') prs p "" `shouldParse` "" context "when there are two many combinators in a row that parse nothing" $ it "accumulated hints are reflected in parse error" $ do let p = many (char 'a') *> many (char 'b') *> eof prs p "c" `shouldFailWith` err posI (utok 'c' <> etok 'a' <> etok 'b' <> eeof) context "when the argument parser succeeds without consuming" $ it "is run nevertheless" $ property $ \n' -> do let n = getSmall (getNonNegative n') :: Integer p = void . many $ do x <- S.get if x < n then S.modify (+ 1) else empty v :: S.State Integer (Either (ParseError Char Dec) ()) v = runParserT p "" "" S.execState v 0 `shouldBe` n describe "some" $ do context "when stream begins with things argument of some parses" $ it "they are parsed" $ property $ \a' b' c' -> do let a = getPositive a' [b,c] = getNonNegative <$> [b',c'] p = some (char 'a') s = abcRow a b c prs p s `shouldParse` replicate a 'a' prs' p s `succeedsLeaving` drop a s context "when stream does not begin with thing argument of some parses" $ it "signals correct parse error" $ property $ \a' b' c' -> do let [a,b,c] = getNonNegative <$> [a',b',c'] p = some (char 'd') s = abcRow a b c ++ "g" prs p s `shouldFailWith` err posI (utok (head s) <> etok 'd') prs' p s `failsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ property $ \ch -> do let p = some (char ch) prs p "" `shouldFailWith` err posI (ueof <> etok ch) context "optional" $ do context "when stream begins with that optional thing" $ it "parses it" $ property $ \a b -> do let p = optional (char a) <* char b s = [a,b] prs p s `shouldParse` Just a prs' p s `succeedsLeaving` "" context "when stream does not begin with that optional thing" $ it "succeeds parsing nothing" $ property $ \a b -> a /= b ==> do let p = optional (char a) <* char b s = [b] prs p s `shouldParse` Nothing prs' p s `succeedsLeaving` "" context "when stream is empty" $ it "succeeds parsing nothing" $ property $ \a -> do let p = optional (char a) prs p "" `shouldParse` Nothing describe "ParsecT Monad instance" $ do it "satisfies left identity law" $ property $ \a k' -> do let k = return . (+ k') p = return (a :: Int) >>= k prs p "" `shouldBe` prs (k a) "" it "satisfies right identity law" $ property $ \a -> do let m = return (a :: Int) p = m >>= return prs p "" `shouldBe` prs m "" it "satisfies associativity law" $ property $ \m' k' h' -> do let m = return (m' :: Int) k = return . (+ k') h = return . (* h') p = m >>= (\x -> k x >>= h) p' = (m >>= k) >>= h prs p "" `shouldBe` prs p' "" it "fails signals correct parse error" $ property $ \msg -> do let p = fail msg :: Parsec Dec String () prs p "" `shouldFailWith` err posI (cstm (DecFail msg)) it "pure is the same as return" $ property $ \n -> prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" it "(<*>) is the same as ap" $ property $ \m' k' -> do let m = return (m' :: Int) k = return (+ k') prs (k <*> m) "" `shouldBe` prs (k `ap` m) "" describe "ParsecT MonadFail instance" $ describe "fail" $ it "signals correct parse error" $ property $ \s msg -> do let p = void (fail msg) prs p s `shouldFailWith` err posI (cstm $ DecFail msg) prs' p s `failsLeaving` s describe "ParsecT MonadIO instance" $ it "liftIO works" $ property $ \n -> do let p = liftIO (return n) :: ParsecT Dec String IO Integer runParserT p "" "" `shouldReturn` Right n describe "ParsecT MonadReader instance" $ do describe "ask" $ it "returns correct value of context" $ property $ \n -> do let p = ask :: ParsecT Dec String (Reader Integer) Integer runReader (runParserT p "" "") n `shouldBe` Right n describe "local" $ it "modifies reader context correctly" $ property $ \n k -> do let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer runReader (runParserT p "" "") n `shouldBe` Right (n + k) describe "ParsecT MonadState instance" $ do describe "get" $ it "returns correct state value" $ property $ \n -> do let p = L.get :: ParsecT Dec String (L.State Integer) Integer L.evalState (runParserT p "" "") n `shouldBe` Right n describe "put" $ it "replaces state value" $ property $ \a b -> do let p = L.put b :: ParsecT Dec String (L.State Integer) () L.execState (runParserT p "" "") a `shouldBe` b describe "ParsecT MonadCont instance" $ describe "callCC" $ it "works properly" $ property $ \a b -> do let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer p = callCC $ \e -> when (a > b) (e a) >> return b runCont (runParserT p "" "") id `shouldBe` Right (max a b) describe "ParsecT MonadError instance" $ do describe "throwError" $ it "throws the error" $ property $ \a b -> do let p :: ParsecT Dec String (Except Integer) Integer p = throwError a >> return b runExcept (runParserT p "" "") `shouldBe` Left a describe "catchError" $ it "catches the error" $ property $ \a b -> do let p :: ParsecT Dec String (Except Integer) Integer p = (throwError a >> return b) `catchError` handler handler e = return (e + b) runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b) describe "primitive combinators" $ do describe "unexpected" $ it "signals correct parse error" $ property $ \item -> do let p :: MonadParsec Dec String m => m () p = void (unexpected item) grs p "" (`shouldFailWith` ParseError { errorPos = posI , errorUnexpected = E.singleton item , errorExpected = E.empty , errorCustom = E.empty }) describe "match" $ it "return consumed tokens along with the result" $ property $ \str -> do let p = match (string str) prs p str `shouldParse` (str,str) prs' p str `succeedsLeaving` "" describe "region" $ do context "when inner parser succeeds" $ it "has no effect" $ property $ \st e n -> do let p :: Parser Int p = region (const e) (pure n) runParser' p st `shouldBe` (st, Right (n :: Int)) context "when inner parser fails" $ it "the given function is used on the parse error" $ property $ \st e0 e1 -> do let p :: Parser Int p = region f $ failure (errorUnexpected e0) (errorExpected e0) (errorCustom e0) f x = ParseError { errorPos = ((G.<>) `on` errorPos) x e1 , errorUnexpected = (E.union `on` errorUnexpected) x e1 , errorExpected = (E.union `on` errorExpected) x e1 , errorCustom = (E.union `on` errorCustom) x e1 } r = ParseError { errorPos = finalPos , errorUnexpected = (E.union `on` errorUnexpected) e0 e1 , errorExpected = (E.union `on` errorExpected) e0 e1 , errorCustom = (E.union `on` errorCustom) e0 e1 } finalPos = statePos st G.<> errorPos e1 runParser' p st `shouldBe` (st { statePos = finalPos }, Left r) describe "failure" $ it "signals correct parse error" $ property $ \us ps xs -> do let p :: MonadParsec Dec String m => m () p = void (failure us ps xs) grs p "" (`shouldFailWith` ParseError { errorPos = posI , errorUnexpected = us , errorExpected = ps , errorCustom = xs }) describe "label" $ do context "when inner parser succeeds consuming input" $ do context "inner parser does not produce any hints" $ it "collection of hints remains empty" $ property $ \lbl a -> not (null lbl) ==> do let p :: MonadParsec Dec String m => m Char p = label lbl (char a) <* empty s = [a] grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty) grs' p s (`failsLeaving` "") context "inner parser produces hints" $ it "replaces the last hint with “the rest of