megaparsec 6.3.0 → 6.4.0
raw patch · 15 files changed
+574/−231 lines, 15 filesdep ~QuickCheckdep ~parser-combinators
Dependency ranges changed: QuickCheck, parser-combinators
Files
- CHANGELOG.md +25/−0
- README.md +4/−2
- Text/Megaparsec.hs +8/−8
- Text/Megaparsec/Char/Lexer.hs +1/−1
- Text/Megaparsec/Perm.hs +6/−5
- bench/memory/Main.hs +1/−0
- bench/speed/Main.hs +1/−0
- megaparsec.cabal +6/−4
- tests/Control/Applicative/CombinatorsSpec.hs +242/−202
- tests/Control/Monad/CombinatorsSpec.hs +244/−0
- tests/Test/Hspec/Megaparsec/AdHoc.hs +12/−0
- tests/Text/Megaparsec/Char/LexerSpec.hs +4/−1
- tests/Text/Megaparsec/CharSpec.hs +4/−2
- tests/Text/Megaparsec/ExprSpec.hs +1/−1
- tests/Text/MegaparsecSpec.hs +15/−5
CHANGELOG.md view
@@ -1,3 +1,28 @@+## Megaparsec 6.4.0++* `Text.Megaparsec` now re-exports `Control.Monad.Combinators` instead of+ `Control.Applicative.Combinators` from `parser-combinators` because the+ monadic counterparts of the familiar combinators are more efficient and+ not as leaky.++ This may cause minor breakage in certain cases:++ * You import `Control.Applicative` and in that case there will be a name+ conflict between `Control.Applicative.many` and+ `Control.Monad.Combinator.many` now (the same for `some`).++ * You define a polymorphic helper in terms of combinator(s) from+ `Control.Applicative.Combinators` and use `Applicative` or `Alternative`+ constraint. In this case you'll have to adjust the constraint to be+ `Monad` or `MonadPlus` respectively.++ Also note that the new `Control.Monad.Combinators` module we re-export now+ re-exports `empty` from `Control.Applicative`.++* Fix the `atEnd` parser. It now does not produce hints, so when you use it,+ it won't contribute to the “expecting end of input” component of parse+ error.+ ## Megaparsec 6.3.0 * Added an `IsString` instance for `ParsecT`. Now it is possible to
README.md view
@@ -33,8 +33,8 @@ * [License](#license) This is an industrial-strength monadic parser combinator library. Megaparsec-is a fork of [Parsec](https://github.com/haskell/parsec) library originally-written by Daan Leijen.+is a feature-rich package that strikes a nice balance between speed,+flexibility, and quality of parse errors. ## Features @@ -387,6 +387,8 @@ ## Prominent projects that use Megaparsec +* [Idris](https://github.com/idris-lang/Idris-dev)—a general-purpose+ functional programming language with dependent types * [Hledger](https://github.com/simonmichael/hledger)—an accounting tool * [Stache](https://github.com/stackbuilders/stache)—Mustache templates for Haskell * [Language Puppet](https://github.com/bartavelle/language-puppet)—library
Text/Megaparsec.hs view
@@ -77,7 +77,7 @@ module Text.Megaparsec.Pos , module Text.Megaparsec.Error , module Text.Megaparsec.Stream- , module Control.Applicative.Combinators+ , module Control.Monad.Combinators -- * Data types , State (..) , Parsec@@ -118,9 +118,9 @@ , dbg ) where -import Control.Applicative.Combinators import Control.DeepSeq import Control.Monad+import Control.Monad.Combinators import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.Identity@@ -159,14 +159,14 @@ -- $reexports ----- Also note that you can import "Control.Applicative.Combinators.NonEmpty"--- if you wish that combinators like 'some' return 'NonEmpty' lists. The--- module lives in the @parser-combinators@ package (you need at least--- version /0.2.0/).+-- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you+-- wish that combinators like 'some' return 'NonEmpty' lists. The module+-- lives in the @parser-combinators@ package (you need at least version+-- /0.4.0/). -- -- This module is intended to be imported qualified: ----- > import qualified Control.Applicative.Combinators.NonEmpty as NE+-- > import qualified Control.Monad.Combinators.NonEmpty as NE ---------------------------------------------------------------------------- -- Data types@@ -1406,7 +1406,7 @@ -- @since 6.0.0 atEnd :: MonadParsec e s m => m Bool-atEnd = option False (True <$ eof)+atEnd = option False (True <$ hidden eof) {-# INLINE atEnd #-} ----------------------------------------------------------------------------
Text/Megaparsec/Char/Lexer.hs view
@@ -561,7 +561,7 @@ => m () -- ^ How to consume white space after the sign -> m a -- ^ How to parse the number itself -> m a -- ^ Parser for signed numbers-signed spc p = ($) <$> option id (lexeme spc sign) <*> p+signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ C.char '+') <|> (negate <$ C.char '-') {-# INLINEABLE signed #-}
Text/Megaparsec/Perm.hs view
@@ -29,7 +29,7 @@ import Text.Megaparsec #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))+import Control.Applicative #endif infixl 1 <||>, <|?>@@ -61,10 +61,11 @@ 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]+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
bench/memory/Main.hs view
@@ -37,6 +37,7 @@ bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) bparser "skipMany" manyAs (const $ skipMany (char 'a')) bparser "skipSome" manyAs (const $ skipSome (char 'a'))+ bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a'))
bench/speed/Main.hs view
@@ -35,6 +35,7 @@ , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) , bparser "skipMany" manyAs (const $ skipMany (char 'a')) , bparser "skipSome" manyAs (const $ skipSome (char 'a'))+ , bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) , bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) , bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) , bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a'))
megaparsec.cabal view
@@ -1,5 +1,5 @@ name: megaparsec-version: 6.3.0+version: 6.4.0 cabal-version: >= 1.18 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 license: BSD2@@ -16,8 +16,9 @@ build-type: Simple description: - This is industrial-strength monadic parser combinator library. Megaparsec- is a fork of Parsec library originally written by Daan Leijen.+ This is an industrial-strength monadic parser combinator library.+ Megaparsec is a feature-rich package that strikes a nice balance between+ speed, flexibility, and quality of parse errors. extra-doc-files: AUTHORS.md , CHANGELOG.md@@ -39,7 +40,7 @@ , containers >= 0.5 && < 0.6 , deepseq >= 1.3 && < 1.5 , mtl >= 2.0 && < 3.0- , parser-combinators >= 0.1 && < 0.3+ , parser-combinators >= 0.4 && < 1.0 , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6@@ -74,6 +75,7 @@ else ghc-options: -O2 -Wall other-modules: Control.Applicative.CombinatorsSpec+ , Control.Monad.CombinatorsSpec , Test.Hspec.Megaparsec , Test.Hspec.Megaparsec.AdHoc , Text.Megaparsec.Byte.LexerSpec
tests/Control/Applicative/CombinatorsSpec.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} module Control.Applicative.CombinatorsSpec (spec) where -import Control.Applicative import Data.Char (isLetter, isDigit) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)@@ -14,228 +14,268 @@ import Text.Megaparsec import Text.Megaparsec.Char +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative hiding (many, some)+#endif+ 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 (drop b post) )- else prs_ p s `shouldParse` z+ 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 (drop b post) )+ 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 "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" $ do+ 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+ rightOrder (count 3 letterChar) "abc" "abc" - 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 "count'" $ do+ 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)+ rightOrder (count' 1 3 letterChar) "abc" "abc" - 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 "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 "endBy" $ do+ 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'+ rightOrder (endBy letterChar (char ',')) "a,b,c," "abc" - 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 "endBy1" $ do+ 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'+ rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc" - 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+ describe "manyTill" $ do+ 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)+ rightOrder (manyTill letterChar (char 'd')) "abcd" "abc"++ describe "someTill" $ do+ 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)+ rightOrder (someTill letterChar (char 'd')) "abcd" "abc" - 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 "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" $ do+ 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)+ rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc" - 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" $ do+ 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)+ rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc" - 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" $ do+ 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)+ rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc" - 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" $ do+ 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)+ rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc" - 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 "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 - 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+ describe "skipCount" $+ it "works" . property $ \c n' a -> do+ let p = skipCount n (char c) *> string a+ n = getNonNegative n'+ p' = count n (char c) *> string a+ s = replicate n c ++ a+ prs_ p s `shouldBe` prs_ p' s - describe "skipManyTill" . it "works" . property $ \c n' a -> c /= a ==> do- let p = skipManyTill (char c) (char a)- n = getNonNegative n'- s = replicate n c ++ [a]- prs_ p s `shouldParse` a+ describe "skipManyTill" $+ it "works" . property $ \c n' a -> c /= a ==> do+ let p = skipManyTill (char c) (char a)+ n = getNonNegative n'+ s = replicate n c ++ [a]+ prs_ p s `shouldParse` a - describe "skipSomeTill" . it "works" . property $ \c n' a -> c /= a ==> do- let p = skipSomeTill (char c) (char a)- n = getNonNegative n'- s = replicate n c ++ [a]- if n == 0- then prs_ p s `shouldFailWith` err posI (utok a <> etok c)- else prs_ p s `shouldParse` a+ describe "skipSomeTill" $+ it "works" . property $ \c n' a -> c /= a ==> do+ let p = skipSomeTill (char c) (char a)+ n = getNonNegative n'+ s = replicate n c ++ [a]+ if n == 0+ then prs_ p s `shouldFailWith` err posI (utok a <> etok c)+ else prs_ p s `shouldParse` a ---------------------------------------------------------------------------- -- Helpers
+ tests/Control/Monad/CombinatorsSpec.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module Control.Monad.CombinatorsSpec (spec) where++import Data.List (intersperse)+import Data.Maybe (maybeToList, isNothing, fromJust)+import Data.Monoid+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Char++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative hiding (many, some)+#endif++spec :: Spec+spec = do++ describe "count" $ do+ 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+ rightOrder (count 3 letterChar) "abc" "abc"++ describe "count'" $ do+ 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)+ rightOrder (count' 1 3 letterChar) "abc" "abc"++ describe "endBy" $ do+ 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'+ rightOrder (endBy letterChar (char ',')) "a,b,c," "abc"++ describe "endBy1" $ do+ 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'+ rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc"++ describe "manyTill" $ do+ 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)+ rightOrder (manyTill letterChar (char 'd')) "abcd" "abc"++ describe "someTill" $ do+ 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)+ rightOrder (someTill letterChar (char 'd')) "abcd" "abc"++ describe "sepBy" $ do+ 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)+ rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"++ describe "sepBy1" $ do+ 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)+ rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"++ describe "sepEndBy" $ do+ 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)+ rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"++ describe "sepEndBy1" $ do+ 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)+ rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"++ 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++ describe "skipCount" $+ it "works" . property $ \c n' a -> do+ let p = skipCount n (char c) *> string a+ n = getNonNegative n'+ p' = count n (char c) *> string a+ s = replicate n c ++ a+ prs_ p s `shouldBe` prs_ p' s++ describe "skipManyTill" $+ it "works" . property $ \c n' a -> c /= a ==> do+ let p = skipManyTill (char c) (char a)+ n = getNonNegative n'+ s = replicate n c ++ [a]+ prs_ p s `shouldParse` a++ describe "skipSomeTill" $+ it "works" . property $ \c n' a -> c /= a ==> do+ let p = skipSomeTill (char c) (char a)+ n = getNonNegative n'+ s = replicate n c ++ [a]+ if n == 0+ then prs_ p s `shouldFailWith` err posI (utok a <> etok c)+ else prs_ p s `shouldParse` a++----------------------------------------------------------------------------+-- Helpers++g :: Int -> Int+g x = x + if x > 0 then x - 1 else 0
tests/Test/Hspec/Megaparsec/AdHoc.hs view
@@ -17,6 +17,7 @@ -- * Other , abcRow , toFirstMismatch+ , rightOrder , Parser ) where @@ -169,6 +170,17 @@ -> String -- ^ Resulting prefix toFirstMismatch f str s = take (n + 1) s where n = length (takeWhile (uncurry f) (zip str s))++-- | Check that the given parser returns the list in the right order.++rightOrder+ :: Parser String -- ^ The parser to test+ -> String -- ^ Input for the parser+ -> String -- ^ Expected result+ -> Spec+rightOrder p s s' =+ it "produces the list in the right order" $+ prs_ p s `shouldParse` s' -- | The type of parser that consumes a 'String'.
tests/Text/Megaparsec/Char/LexerSpec.hs view
@@ -6,7 +6,6 @@ module Text.Megaparsec.Char.LexerSpec (spec) where -import Control.Applicative import Control.Monad import Data.Char hiding (ord) import Data.List (isInfixOf)@@ -22,6 +21,10 @@ import Text.Megaparsec import Text.Megaparsec.Char.Lexer import qualified Text.Megaparsec.Char as C++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative hiding (many, some)+#endif spec :: Spec spec = do
tests/Text/Megaparsec/CharSpec.hs view
@@ -205,9 +205,11 @@ prs (char ch) "" `shouldFailWith` err posI (ueof <> etok ch) describe "char'" $ do+ let goodChar x =+ (toUpper x == toLower x) || (isUpper x || isLower x) context "when stream begins with the character specified as argument" $ it "parses the character" $- property $ \ch s -> do+ property $ \ch s -> goodChar ch ==> do let sl = toLower ch : s su = toUpper ch : s prs (char' ch) sl `shouldParse` toLower ch@@ -216,7 +218,7 @@ 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+ property $ \ch ch' s -> goodChar ch && 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
tests/Text/Megaparsec/ExprSpec.hs view
@@ -14,7 +14,7 @@ import Text.Megaparsec.Expr #if !MIN_VERSION_base(4,8,0)-import Control.Applicative+import Control.Applicative hiding (many, some) #endif spec :: Spec
tests/Text/MegaparsecSpec.hs view
@@ -11,7 +11,6 @@ module Text.MegaparsecSpec (spec) where -import Control.Applicative import Control.Monad.Cont import Control.Monad.Except import Control.Monad.Identity@@ -46,6 +45,10 @@ import qualified Data.Text as T import qualified Data.ByteString as BS +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative hiding (many, some)+#endif+ #if !MIN_VERSION_QuickCheck(2,8,2) instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where arbitrary = E.fromList <$> arbitrary@@ -1284,16 +1287,23 @@ runParser' p st `shouldBe` (st', Right stateInput) describe "atEnd" $ do- let p :: Parser Bool- p = atEnd- context "when stream is empty" $+ let p, p' :: Parser Bool+ p = atEnd+ p' = p <* empty+ context "when stream is empty" $ do it "returns True" $ prs p "" `shouldParse` True- context "when stream is not empty" $+ it "does not produce hints" $+ prs p' "" `shouldFailWith` err posI mempty+ context "when stream is not empty" $ do it "returns False" $ property $ \s -> not (null s) ==> do prs p s `shouldParse` False prs' p s `succeedsLeaving` s+ it "does not produce hints" $+ property $ \s -> not (null s) ==> do+ prs p' s `shouldFailWith` err posI mempty+ prs' p' s `failsLeaving` s describe "combinators for manipulating parser state" $ do