megaparsec 7.0.4 → 7.0.5
raw patch · 35 files changed
+43/−5610 lines, 35 filesdep −QuickCheckdep −faildep −hspecdep ~base
Dependencies removed: QuickCheck, fail, hspec, hspec-expectations, semigroups, void
Dependency ranges changed: base
Files
- CHANGELOG.md +16/−0
- LICENSE.md +2/−2
- README.md +1/−1
- Text/Megaparsec.hs +1/−1
- Text/Megaparsec/Byte.hs +1/−1
- Text/Megaparsec/Byte/Lexer.hs +1/−1
- Text/Megaparsec/Char.hs +1/−1
- Text/Megaparsec/Char/Lexer.hs +1/−1
- Text/Megaparsec/Class.hs +1/−1
- Text/Megaparsec/Common.hs +1/−1
- Text/Megaparsec/Debug.hs +1/−1
- Text/Megaparsec/Error.hs +1/−1
- Text/Megaparsec/Error/Builder.hs +1/−1
- Text/Megaparsec/Internal.hs +4/−2
- Text/Megaparsec/Lexer.hs +1/−1
- Text/Megaparsec/Pos.hs +1/−1
- Text/Megaparsec/State.hs +1/−1
- Text/Megaparsec/Stream.hs +1/−3
- megaparsec.cabal +6/−61
- tests/Control/Applicative/CombinatorsSpec.hs +0/−279
- tests/Control/Applicative/PermutationsSpec.hs +0/−103
- tests/Control/Monad/Combinators/ExprSpec.hs +0/−160
- tests/Control/Monad/CombinatorsSpec.hs +0/−239
- tests/Main.hs +0/−52
- tests/Test/Hspec/Megaparsec.hs +0/−302
- tests/Test/Hspec/Megaparsec/AdHoc.hs +0/−327
- tests/Text/Megaparsec/Byte/LexerSpec.hs +0/−314
- tests/Text/Megaparsec/ByteSpec.hs +0/−236
- tests/Text/Megaparsec/Char/LexerSpec.hs +0/−569
- tests/Text/Megaparsec/CharSpec.hs +0/−348
- tests/Text/Megaparsec/DebugSpec.hs +0/−55
- tests/Text/Megaparsec/ErrorSpec.hs +0/−280
- tests/Text/Megaparsec/PosSpec.hs +0/−63
- tests/Text/Megaparsec/StreamSpec.hs +0/−550
- tests/Text/MegaparsecSpec.hs +0/−1651
CHANGELOG.md view
@@ -1,3 +1,19 @@+## Megaparsec 7.0.5++* Dropped support for GHC 7.10.++* Adapted the code to `MonadFail` changes in `base-4.13`.++* Separated the test suite into its own package. The reason is that we can+ avoid circular dependency on `hspec-megaparsec` and thus avoid keeping+ copies of its source files in our test suite, as we had to do before.+ Another benefit is that we can export some auxiliary functions in+ `megaparsec-tests` which can be used by other test suites, for example in+ the `parser-combinators-tests` package.++ Version of `megaparsec-tests` will be kept in sync with versions of+ `megaparsec` from now on.+ ## Megaparsec 7.0.4 * Numerous documentation corrections.
LICENSE.md view
@@ -1,5 +1,5 @@-Copyright © 2015–2018 Megaparsec contributors<br>-Copyright © 2007 Paolo Martini<br>+Copyright © 2015–2019 Megaparsec contributors\+Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen All rights reserved.
README.md view
@@ -334,7 +334,7 @@ ## License -Copyright © 2015–2018 Megaparsec contributors\+Copyright © 2015–2019 Megaparsec contributors\ Copyright © 2007 Paolo Martini\ Copyright © 1999–2000 Daan Leijen
Text/Megaparsec.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Byte.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Byte--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Byte/Lexer.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Byte.Lexer--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Char.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Char--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Char/Lexer.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Char.Lexer--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Class.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Class--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Common.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Common--- Copyright : © 2018 Megaparsec contributors+-- Copyright : © 2018–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Debug.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Debug--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Error.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Error--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Error/Builder.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Error.Builder--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Internal.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Internal--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD@@ -25,7 +25,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)+#if !MIN_VERSION_base(4,11,0) {-# OPTIONS -Wno-noncanonical-monoid-instances #-} #endif @@ -200,7 +200,9 @@ instance Stream s => Monad (ParsecT e s m) where return = pure (>>=) = pBind+#if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail+#endif pBind :: Stream s => ParsecT e s m a
Text/Megaparsec/Lexer.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Common--- Copyright : © 2018 Megaparsec contributors+-- Copyright : © 2018–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/Pos.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Pos--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>
Text/Megaparsec/State.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.State--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Stream.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Stream--- Copyright : © 2015–2018 Megaparsec contributors+-- Copyright : © 2015–2019 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov92@gmail.com>@@ -300,8 +300,6 @@ -- unboxed 'SourcePos'. data St = St SourcePos ShowS---- {-# UNPACK #-} -- TODO do we need to unpack or not? -- | A helper definition to facilitate defining 'reachOffset' for various -- stream types.
megaparsec.cabal view
@@ -1,7 +1,7 @@ name: megaparsec-version: 7.0.4+version: 7.0.5 cabal-version: 1.18-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 license: BSD2 license-file: LICENSE.md author: Megaparsec contributors,@@ -34,7 +34,7 @@ default: False library- build-depends: base >= 4.8 && < 5.0+ build-depends: base >= 4.9 && < 5.0 , bytestring >= 0.2 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5 && < 0.7@@ -44,11 +44,6 @@ , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6- if !impl(ghc >= 8.0)- build-depends: fail == 4.9.*- , semigroups == 0.18.*- if !impl(ghc >= 7.10)- build-depends: void == 0.7.* exposed-modules: Text.Megaparsec , Text.Megaparsec.Byte , Text.Megaparsec.Byte.Lexer@@ -68,7 +63,7 @@ ghc-options: -O0 -Wall -Werror else ghc-options: -O2 -Wall- if flag(dev) && impl(ghc >= 8.0)+ if flag(dev) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns@@ -76,62 +71,16 @@ -Wnoncanonical-monadfail-instances default-language: Haskell2010 -test-suite tests- main-is: Main.hs- hs-source-dirs: tests- type: exitcode-stdio-1.0- if flag(dev)- ghc-options: -O0 -Wall -Werror- else- ghc-options: -O2 -Wall- other-modules: Control.Applicative.CombinatorsSpec- , Control.Applicative.PermutationsSpec- , Control.Monad.Combinators.ExprSpec- , Control.Monad.CombinatorsSpec- , Test.Hspec.Megaparsec- , Test.Hspec.Megaparsec.AdHoc- , Text.Megaparsec.Byte.LexerSpec- , Text.Megaparsec.ByteSpec- , Text.Megaparsec.Char.LexerSpec- , Text.Megaparsec.CharSpec- , Text.Megaparsec.DebugSpec- , Text.Megaparsec.ErrorSpec- , Text.Megaparsec.PosSpec- , Text.Megaparsec.StreamSpec- , Text.MegaparsecSpec- build-depends: QuickCheck >= 2.7 && < 2.13- , base >= 4.8 && < 5.0- , bytestring >= 0.2 && < 0.11- , case-insensitive >= 1.2 && < 1.3- , containers >= 0.5 && < 0.7- , hspec >= 2.0 && < 3.0- , hspec-expectations >= 0.8 && < 0.9- , megaparsec- , mtl >= 2.0 && < 3.0- , parser-combinators >= 1.0 && < 2.0- , scientific >= 0.3.1 && < 0.4- , text >= 0.2 && < 1.3- , transformers >= 0.4 && < 0.6- if !impl(ghc >= 8.0)- build-depends: semigroups == 0.18.*- if !impl(ghc >= 7.10)- build-depends: void == 0.7.*- default-language: Haskell2010- benchmark bench-speed main-is: Main.hs hs-source-dirs: bench/speed type: exitcode-stdio-1.0- build-depends: base >= 4.8 && < 5.0+ build-depends: base >= 4.9 && < 5.0 , containers >= 0.5 && < 0.7 , criterion >= 0.6.2.1 && < 1.6 , deepseq >= 1.3 && < 1.5 , megaparsec , text >= 0.2 && < 1.3- if !impl(ghc >= 8.0)- build-depends: semigroups == 0.18.*- if !impl(ghc >= 7.10)- build-depends: void == 0.7.* if flag(dev) ghc-options: -O2 -Wall -Werror else@@ -142,16 +91,12 @@ main-is: Main.hs hs-source-dirs: bench/memory type: exitcode-stdio-1.0- build-depends: base >= 4.8 && < 5.0+ build-depends: base >= 4.9 && < 5.0 , containers >= 0.5 && < 0.7 , deepseq >= 1.3 && < 1.5 , megaparsec , text >= 0.2 && < 1.3 , weigh >= 0.0.4- if !impl(ghc >= 8.0)- build-depends: semigroups == 0.18.*- if !impl(ghc >= 7.10)- build-depends: void == 0.7.* if flag(dev) ghc-options: -O2 -Wall -Werror else
− tests/Control/Applicative/CombinatorsSpec.hs
@@ -1,279 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}--module Control.Applicative.CombinatorsSpec (spec) where--import Control.Applicative.Combinators-import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#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 (length pre + n + b)- ( 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 0 (utok s' <> mconcat (etok <$> cs))-- 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 0 (utok 'x' <> eeof)- | m <= x && x <= n ->- prs_ p s `shouldParse` s- | x < m ->- prs_ p s `shouldFailWith` err x (ueof <> etok 'x')- | otherwise ->- prs_ p s `shouldFailWith` err n (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 0 (utok ch <> elabel "letter" <> elabel "digit")-- 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 1 (ueof <> etok '-')- | c == 'a' ->- prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')- | c == '-' && n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a'<> eeof)- | c /= '-' ->- prs_ p s `shouldFailWith` err (g n)- ( 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 1 (ueof <> etok '-')- | c == 'a' ->- prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')- | c == '-' && n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a')- | c /= '-' ->- prs_ p s `shouldFailWith` err (g n)- ( 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 (a + b)- (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 0 (ueof <> elabel "letter")- | c == 0 ->- prs_ p s `shouldFailWith` err (a + b)- (ueof <> etok 'c' <> elabel "letter")- | s == "c" ->- prs_ p s `shouldFailWith` err 1 (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 "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 0 (utok c <> etok 'a' <> eeof)- | c == '-' ->- prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (ueof <> etok 'a')- | c == 'a' && n == 0 ->- prs_ p s `shouldParse` "a"- | n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')- | c == '-' ->- prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (utok c <> etok 'a' <> eeof)- | c == '-' ->- prs_ p s `shouldParse` a- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (ueof <> etok 'a')- | c == 'a' && n == 0 ->- prs_ p s `shouldParse` "a"- | n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')- | c == '-' ->- prs_ p s `shouldParse` a- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (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/Control/Applicative/PermutationsSpec.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module Control.Applicative.PermutationsSpec (spec) where--import Control.Applicative.Permutations-import Control.Monad-import Data.Void-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char--spec :: Spec-spec = do- describe "runPermutation & Permutation" $ do- describe "Functor instance" $ do- it "obeys identity law" $- property $ \n ->- prsp (fmap id (pure (n :: Int))) "" ===- prsp (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 "Applicative instance" $ do- it "obeys identity law" $- property $ \n ->- prsp (pure id <*> pure (n :: Int)) "" ===- prsp (pure n) ""- it "obeys composition law" $- property $ \n m t ->- let u = pure (+ m)- v = pure (* t)- w = pure (n :: Int)- in prsp (pure (.) <*> u <*> v <*> w) "" ===- prsp (u <*> (v <*> w)) ""- it "obeys homomorphism law" $- property $ \x m ->- let f = (+ m)- in prsp (pure f <*> pure (x :: Int)) "" ===- prsp (pure (f x)) ""- it "obeys interchange law" $- property $ \n y ->- let u = pure (+ n)- in prsp (u <*> pure (y :: Int)) "" ===- prsp (pure ($ y) <*> u) ""- describe "toPermutation" $- it "works" $- property $ \xs s' -> forAll (shuffle xs) $ \ys -> do- let s = ys ++ s'- p = foldr f (pure []) xs- f x p' = (:) <$> toPermutation (char x) <*> p'- prsp p s `shouldParse` xs- prsp' p s `succeedsLeaving` s'- describe "toPermutationWithDefault" $ do- let testCases =- [ ("abc", "abc", "")- , ("cba", "abc", "")- , ("bbc", "xbz", "bc")- , ("aaa", "ayz", "aa")- , ("", "xyz", "")- ]- forM_ testCases $ \(i, o, r) ->- it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do- prsp testPermParser i `shouldParse` o- prsp' testPermParser i `succeedsLeaving` r- describe "intercalateEffect" $ do- let p = intercalateEffect (char ',') testPermParser- testCases =- [ ("a,b,c", "abc", "")- , ("c,b,a", "abc", "")- , ("b,b,c", "xbz", "b,c")- , ("a,a,a", "ayz", "a,a")- , (",", "xyz", ",")- ]- forM_ testCases $ \(i, o, r) ->- it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do- prs p i `shouldParse` o- prs' p i `succeedsLeaving` r--prsp- :: Permutation Parser a- -> String- -> Either (ParseErrorBundle String Void) a-prsp p = prs (runPermutation p)--prsp'- :: Permutation Parser a- -> String- -> (State String, Either (ParseErrorBundle String Void) a)-prsp' p = prs' (runPermutation p)--testPermParser :: Permutation Parser String-testPermParser =- f <$> toPermutationWithDefault 'x' (char 'a')- <*> toPermutationWithDefault 'y' (char 'b')- <*> toPermutationWithDefault 'z' (char 'c')- where- f a b c = [a,b,c]
− tests/Control/Monad/Combinators/ExprSpec.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--module Control.Monad.Combinators.ExprSpec (spec) where--import Control.Monad.Combinators.Expr-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--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 0- (ueof <> etok '-' <> elabel "term")- context "when term is missing" $- it "signals correct parse error" $ do- let p = expr <* eof- prs p "-" `shouldFailWith` err 1 (ueof <> elabel "term")- prs p "(" `shouldFailWith` err 1 (ueof <> etok '-' <> elabel "term")- prs p "*" `shouldFailWith` err 0 (utok '*' <> etok '-' <> 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 n (mconcat- [ utok c- , eeof- , etok '!'- , etok '%'- , etok '*'- , etok '+'- , etok '-'- , etok '/'- , etok '^'- ])--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)--lexeme :: Parser a -> Parser a-lexeme p = p <* hidden space--symbol :: String -> Parser String-symbol = lexeme . string--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--integer :: Parser 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 :: Parser Node-expr = makeExprParser term table--term :: Parser Node-term = parens expr <|> (Val <$> integer) <?> "term"--table :: [[Operator Parser Node]]-table =- [ [ Prefix (Neg <$ symbol "-")- , Postfix (Fac <$ symbol "!")- , InfixN (Mod <$ symbol "%") ]- , [ InfixR (Exp <$ symbol "^") ]- , [ InfixL (Pro <$ symbol "*")- , InfixL (Div <$ symbol "/") ]- , [ InfixL (Sum <$ symbol "+")- , InfixL (Sub <$ symbol "-")] ]
− tests/Control/Monad/CombinatorsSpec.hs
@@ -1,239 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}--module Control.Monad.CombinatorsSpec (spec) where--import Control.Monad.Combinators-import Data.List (intersperse)-import Data.Maybe (maybeToList, isNothing, fromJust)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#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 0 (utok 'x' <> eeof)- | m <= x && x <= n ->- prs_ p s `shouldParse` s- | x < m ->- prs_ p s `shouldFailWith` err x (ueof <> etok 'x')- | otherwise ->- prs_ p s `shouldFailWith` err n (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 1 (ueof <> etok '-')- | c == 'a' ->- prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')- | c == '-' && n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a'<> eeof)- | c /= '-' ->- prs_ p s `shouldFailWith` err (g n)- ( 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 (1 :: Int) (ueof <> etok '-')- | c == 'a' ->- prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')- | c == '-' && n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a')- | c /= '-' ->- prs_ p s `shouldFailWith` err (g n)- ( 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 (a + b)- (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 0 (ueof <> elabel "letter")- | c == 0 ->- prs_ p s `shouldFailWith` err (a + b)- (ueof <> etok 'c' <> elabel "letter")- | s == "c" ->- prs_ p s `shouldFailWith` err 1 (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 0 (utok c <> etok 'a' <> eeof)- | c == '-' ->- prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (ueof <> etok 'a')- | c == 'a' && n == 0 ->- prs_ p s `shouldParse` "a"- | n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')- | c == '-' ->- prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (utok c <> etok 'a' <> eeof)- | c == '-' ->- prs_ p s `shouldParse` a- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (ueof <> etok 'a')- | c == 'a' && n == 0 ->- prs_ p s `shouldParse` "a"- | n == 0 ->- prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')- | c == '-' ->- prs_ p s `shouldParse` a- | otherwise ->- prs_ p s `shouldFailWith` err (g n) (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 0 (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/Main.hs
@@ -1,52 +0,0 @@-module Main (main) where--import Test.Hspec-import Test.Hspec.Runner--import qualified Control.Applicative.CombinatorsSpec-import qualified Control.Applicative.PermutationsSpec--import qualified Control.Monad.CombinatorsSpec-import qualified Control.Monad.Combinators.ExprSpec--import qualified Text.MegaparsecSpec--import qualified Text.Megaparsec.ByteSpec-import qualified Text.Megaparsec.Byte.LexerSpec--import qualified Text.Megaparsec.CharSpec-import qualified Text.Megaparsec.Char.LexerSpec--import qualified Text.Megaparsec.DebugSpec-import qualified Text.Megaparsec.ErrorSpec-import qualified Text.Megaparsec.PosSpec-import qualified Text.Megaparsec.StreamSpec---- | Here we define 'spec' manually rather than with @hspec-discover@ so we--- can disable some tests quickly by commenting out the corresponding lines--- here (running all the tests takes a while now).--spec :: Spec-spec = do-- Control.Applicative.CombinatorsSpec.spec- Control.Applicative.PermutationsSpec.spec-- Control.Monad.CombinatorsSpec.spec- Control.Monad.Combinators.ExprSpec.spec-- Text.MegaparsecSpec.spec-- Text.Megaparsec.ByteSpec.spec- Text.Megaparsec.Byte.LexerSpec.spec-- Text.Megaparsec.CharSpec.spec- Text.Megaparsec.Char.LexerSpec.spec-- Text.Megaparsec.DebugSpec.spec- Text.Megaparsec.ErrorSpec.spec- Text.Megaparsec.PosSpec.spec- Text.Megaparsec.StreamSpec.spec--main :: IO ()-main = hspecWith defaultConfig { configQuickCheckMaxSuccess = Just 1000 } spec
− tests/Test/Hspec/Megaparsec.hs
@@ -1,302 +0,0 @@--- |--- Module : Test.Hspec.Megaparsec--- Copyright : © 2016–2018 Mark Karpov--- License : BSD 3 clause------ Maintainer : Mark Karpov <markkarpov92@gmail.com>--- Stability : experimental--- Portability : portable------ Utility functions for testing Megaparsec parsers with Hspec.------ This version of the library should be used with Megaparsec 7.--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--module Test.Hspec.Megaparsec- ( -- * Basic expectations- shouldParse- , parseSatisfies- , shouldSucceedOn- , shouldFailOn- -- * Testing of error messages- , shouldFailWith- , shouldFailWithM- -- * Incremental parsing- , failsLeaving- , succeedsLeaving- , initialState- , initialPosState- -- * Re-exports- , module Text.Megaparsec.Error.Builder )-where--import Control.Monad (unless)-import Test.Hspec.Expectations-import Text.Megaparsec-import Text.Megaparsec.Error.Builder-import qualified Data.List.NonEmpty as NE--------------------------------------------------------------------------------- Basic expectations---- | Create an expectation by saying what the result should be.------ > parse letterChar "" "x" `shouldParse` 'x'--shouldParse- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- , Eq a- )- => Either (ParseErrorBundle s 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" ++ showBundle 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- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- , Eq a- )- => Either (ParseErrorBundle s 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" ++ showBundle 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- :: (HasCallStack, Show a)- => (s -> Either (ParseErrorBundle s 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- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- )- => (s -> Either (ParseErrorBundle s 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- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- , Eq e- )- => Either (ParseErrorBundle s e) a -- ^ The result of parsing- -> ParseError s e -- ^ Expected parse errors- -> Expectation-r `shouldFailWith` perr1 = r `shouldFailWithM` [perr1]---- | Similar to 'shouldFailWith', but allows to check parsers that can--- report more than one parse error at a time.------ @since 2.0.0--shouldFailWithM- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- , Eq e- )- => Either (ParseErrorBundle s e) a -- ^ The result of parsing- -> [ParseError s e]- -- ^ Expected parse errors, the argument is a normal linked list (as- -- opposed to the more correct 'NonEmpty' list) as a syntactical- -- convenience for the user, passing empty list here will result in an- -- error- -> Expectation-r `shouldFailWithM` perrs1' = case r of- Left e0 ->- let e1 = e0 { bundleErrors = perrs1 }- perrs0 = bundleErrors e0- perrs1 = NE.fromList perrs1'- in unless (perrs0 == perrs1) . expectationFailure $- "the parser is expected to fail with:\n" ++ showBundle e1 ++- "but it failed with:\n" ++ showBundle e0- Right v -> expectationFailure $- "the parser is expected to fail, but it parsed: " ++ show v--------------------------------------------------------------------------------- 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- :: ( HasCallStack- , Show a- , Eq s- , Show s- )- => (State s, Either (ParseErrorBundle 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 = do- 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- :: ( HasCallStack- , Show a- , Eq s- , Show s- , ShowErrorComponent e- , Stream s- )- => (State s, Either (ParseErrorBundle 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 = do- shouldSucceed r- checkUnconsumed s (stateInput st)---- | Given input for parsing, construct initial state for parser.--initialState :: s -> State s-initialState s = State- { stateInput = s- , stateOffset = 0- , statePosState = initialPosState s- }---- | Given input for parsing, construct initial positional state.------ @since 2.0.0--initialPosState :: s -> PosState s-initialPosState s = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }--------------------------------------------------------------------------------- Helpers---- | Expect that the argument is a result of a failed parser.--shouldFail- :: (HasCallStack, Show a)- => Either (ParseErrorBundle s 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- :: ( HasCallStack- , ShowErrorComponent e- , Stream s- , Show a- )- => Either (ParseErrorBundle s e) a- -> Expectation-shouldSucceed r = case r of- Left e -> expectationFailure $- "the parser is expected to succeed, but it failed with:\n" ++- showBundle e- Right _ -> return ()---- | Compare two streams for equality and in the case of mismatch report it.--checkUnconsumed- :: ( HasCallStack- , Eq s- , Show 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 a parse error bundle in a way that is suitable for inserting it--- in a test suite report.--showBundle- :: ( ShowErrorComponent e- , Stream s- )- => ParseErrorBundle s e- -> String-showBundle = unlines . fmap indent . lines . errorBundlePretty- where- indent x = if null x- then x- else " " ++ x
− tests/Test/Hspec/Megaparsec/AdHoc.hs
@@ -1,327 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Test.Hspec.Megaparsec.AdHoc- ( -- * Types- Parser- -- * Helpers to run parsers- , prs- , prs'- , prs_- , grs- , grs'- -- * Other- , nes- , abcRow- , rightOrder- , scaleDown- , getTabWidth- , setTabWidth- , strSourcePos- -- * Char and byte conversion- , toChar- , fromChar- -- * Proxies- , sproxy- , bproxy- , blproxy- , tproxy- , tlproxy )-where--import Control.Monad.Reader-import Control.Monad.Trans.Identity-import Data.Char (chr, ord)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Proxy-import Data.Void-import Data.Word (Word8)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.QuickCheck-import Text.Megaparsec-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 as B-import qualified Data.ByteString.Lazy 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--------------------------------------------------------------------------------- Types---- | The type of parser that consumes a 'String'.--type Parser = Parsec Void String--------------------------------------------------------------------------------- Helpers to run parsers---- | Apply parser to given input. This is a specialized version of 'parse'--- that assumes empty file name.--prs- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> Either (ParseErrorBundle String Void) a- -- ^ Result of parsing-prs p = parse p ""---- | Just like 'prs', but allows to inspect the final state of the parser.--prs'- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> (State String, Either (ParseErrorBundle String Void) a)- -- ^ Result of parsing-prs' p s = runParser' p (initialState s)---- | Just like 'prs', but forces the parser to consume all input by adding--- 'eof':------ > prs_ p = parse (p <* eof) ""--prs_- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> Either (ParseErrorBundle String Void) a- -- ^ Result of parsing-prs_ p = parse (p <* eof) ""---- | Just like 'prs', but interprets given parser as various monads (tries--- all supported monads transformers in turn).--grs- :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run- -> String -- ^ Input for the parser- -> (Either (ParseErrorBundle String Void) 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' is as 'prs'' to 'prs'.--grs'- :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run- -> String -- ^ Input for the parser- -> ((State String, Either (ParseErrorBundle String Void) 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 = fmap fst . L.runWriterT-evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a-evalWriterTS = fmap 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--------------------------------------------------------------------------------- Other---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []---- | @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'---- | 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'---- | Get tab width from 'PosState'. Use with care only for testing.--getTabWidth :: MonadParsec e s m => m Pos-getTabWidth = pstateTabWidth . statePosState <$> getParserState---- | Set tab width in 'PosState'. Use with care only for testing.--setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState $ \st ->- let pst = statePosState st- in st { statePosState = pst { pstateTabWidth = w } }---- | Scale down.--scaleDown :: Gen a -> Gen a-scaleDown = scale (`div` 4)---- | A helper function that is used to advance 'SourcePos' given a 'String'.--strSourcePos :: Pos -> SourcePos -> String -> SourcePos-strSourcePos tabWidth ipos input =- let (x, _, _) = reachOffset maxBound pstate in x- where- pstate = PosState- { pstateInput = input- , pstateOffset = 0- , pstateSourcePos = ipos- , pstateTabWidth = tabWidth- , pstateLinePrefix = ""- }--------------------------------------------------------------------------------- Char and byte conversion---- | Convert a byte to char.--toChar :: Word8 -> Char-toChar = chr . fromIntegral---- | Covert a char to byte.--fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in- if p > 0xff- then Nothing- else Just (fromIntegral p)--------------------------------------------------------------------------------- Proxies--sproxy :: Proxy String-sproxy = Proxy--bproxy :: Proxy B.ByteString-bproxy = Proxy--blproxy :: Proxy BL.ByteString-blproxy = Proxy--tproxy :: Proxy T.Text-tproxy = Proxy--tlproxy :: Proxy TL.Text-tlproxy = Proxy--------------------------------------------------------------------------------- Arbitrary instances--instance Arbitrary Void where- arbitrary = error "Arbitrary Void"--instance Arbitrary Pos where- arbitrary = mkPos <$> (getSmall . getPositive <$> arbitrary)--instance Arbitrary SourcePos where- arbitrary = SourcePos- <$> scaleDown arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary t => Arbitrary (ErrorItem t) where- arbitrary = oneof- [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)- , Label <$> (NE.fromList . getNonEmpty <$> arbitrary)- , return EndOfInput ]--instance Arbitrary (ErrorFancy a) where- arbitrary = oneof- [ ErrorFail <$> scaleDown arbitrary- , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]--instance (Arbitrary (Token s), Ord (Token s), Arbitrary e, Ord e)- => Arbitrary (ParseError s e) where- arbitrary = oneof- [ TrivialError- <$> (getNonNegative <$> arbitrary)- <*> arbitrary- <*> (E.fromList <$> scaleDown arbitrary)- , FancyError- <$> (getNonNegative <$> arbitrary)- <*> (E.fromList <$> scaleDown arbitrary) ]--instance Arbitrary s => Arbitrary (State s) where- arbitrary = do- input <- scaleDown arbitrary- offset <- choose (1, 10000)- pstate :: PosState s <- arbitrary- return State- { stateInput = input- , stateOffset = offset- , statePosState = pstate- { pstateInput = input- , pstateOffset = offset- }- }--instance Arbitrary s => Arbitrary (PosState s) where- arbitrary = PosState- <$> arbitrary- <*> choose (1, 10000)- <*> arbitrary- <*> (mkPos <$> choose (1, 20))- <*> scaleDown arbitrary--instance Arbitrary T.Text where- arbitrary = T.pack <$> arbitrary--instance Arbitrary TL.Text where- arbitrary = TL.pack <$> arbitrary--instance Arbitrary B.ByteString where- arbitrary = B.pack <$> arbitrary--instance Arbitrary BL.ByteString where- arbitrary = BL.pack <$> arbitrary--#if MIN_VERSION_QuickCheck(2,10,0)-instance Arbitrary a => Arbitrary (NonEmpty a) where- arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null))-#endif
− tests/Text/Megaparsec/Byte/LexerSpec.hs
@@ -1,314 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.Byte.LexerSpec (spec) where--import Control.Applicative-import Data.ByteString (ByteString)-import Data.Char (intToDigit, toUpper)-import Data.Monoid ((<>))-import Data.Scientific (Scientific, fromFloatDigits)-import Data.Void-import Data.Word (Word8)-import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Byte.Lexer-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Text.Megaparsec.Byte as B--type Parser = Parsec Void ByteString--spec :: Spec-spec = do-- describe "skipLineComment" $ do- context "when there is no newline at the end of line" $- it "is picked up successfully" $ do- let p = space B.space1 (skipLineComment "//") empty <* eof- s = " // this line comment doesn't have a newline at the end "- prs p s `shouldParse` ()- prs' p s `succeedsLeaving` ""- it "inner characters are labelled properly" $ do- let p = skipLineComment "//" <* empty- s = "// here we go"- prs p s `shouldFailWith` err (B.length s) (elabel "character")- prs' p s `failsLeaving` ""-- describe "skipBlockComment" $- it "skips a simple block comment" $ do- let p = skipBlockComment "/*" "*/"- s = "/* here we go */foo!"- prs p s `shouldParse` ()- prs' p s `succeedsLeaving` "foo!"-- describe "skipBlockCommentNested" $- context "when it runs into nested block comments" $- it "parses them all right" $ do- let p = space B.space1 empty- (skipBlockCommentNested "/*" "*/") <* eof- s = " /* foo bar /* baz */ quux */ "- prs p s `shouldParse` ()- prs' p s `succeedsLeaving` ""-- describe "decimal" $ do- context "when stream begins with decimal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = decimal :: Parser Integer- n = getNonNegative n'- s = B8.pack (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 :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (decimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "integer")-- describe "binary" $ do- context "when stream begins with binary digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = binary :: Parser Integer- n = getNonNegative n'- s = B8.pack (showIntAtBase 2 intToDigit n "")- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "when stream does not begin with binary digits" $- it "signals correct parse error" $- property $ \a as -> a /= 48 && a /= 49 ==> do- let p = binary :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "binary integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (binary :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "binary integer")-- describe "octal" $ do- context "when stream begins with octal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = octal :: Parser Integer- n = getNonNegative n'- s = B8.pack (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 :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "octal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (octal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "octal integer")-- describe "hexadecimal" $ do- context "when stream begins with hexadecimal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = hexadecimal :: Parser Integer- n = getNonNegative n'- s = B8.pack (showHex n "")- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "when stream begins with hexadecimal digits (uppercase)" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = hexadecimal :: Parser Integer- n = getNonNegative n'- s = B8.pack (toUpper <$> 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 :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "hexadecimal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "hexadecimal integer")-- describe "scientific" $ do- context "when stream begins with a number" $- it "parses it" $- property $ \n' -> do- let p = scientific :: Parser Scientific- s = B8.pack $ 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 fractional part is interrupted" $- it "signals correct parse error" $- property $ \(NonNegative n) -> do- let p = scientific <* empty :: Parser Scientific- s = B8.pack (showFFloatAlt Nothing (n :: Double) "")- prs p s `shouldFailWith` err (B.length s)- (etok 69 <> etok 101 <> elabel "digit")- prs' p s `failsLeaving` ""- context "when whole part is followed by a dot without valid fractional part" $- it "parsing of fractional part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = scientific :: Parser Scientific- s = B8.pack $ showInt (n :: Integer) ".err"- prs p s `shouldParse` fromIntegral n- prs' p s `succeedsLeaving` ".err"- context "when number is followed by something starting with 'e'" $- it "parsing of exponent part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = scientific :: Parser Scientific- s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` fromFloatDigits n- prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (scientific :: Parser Scientific) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")-- describe "float" $ do- context "when stream begins with a float" $- it "parses it" $- property $ \n' -> do- let p = float :: Parser Double- n = getNonNegative n'- s = B8.pack (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 :: Parser Double- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "digit")- prs' p s `failsLeaving` s- context "when stream begins with an integer (decimal)" $- it "signals correct parse error" $- property $ \n' -> do- let p = float :: Parser Double- n = getNonNegative n'- s = B8.pack $ show (n :: Integer)- prs p s `shouldFailWith` err (B.length s)- (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit")- prs' p s `failsLeaving` ""- context "when number is followed by something starting with 'e'" $- it "parsing of exponent part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = float :: Parser Double- s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` n- prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (float :: Parser Double) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")- context "when there is float with just exponent" $- it "parses it all right" $ do- let p = float :: Parser Double- prs p "123e3" `shouldParse` 123e3- prs' p "123e3" `succeedsLeaving` ""- prs p "123e+3" `shouldParse` 123e+3- prs' p "123e+3" `succeedsLeaving` ""- prs p "123e-3" `shouldParse` 123e-3- prs' p "123e-3" `succeedsLeaving` ""-- describe "signed" $ do- context "with integer" $- it "parses signed integers" $- property $ \n -> do- let p :: Parser Integer- p = signed (hidden B.space) decimal- s = B8.pack (show n)- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "with float" $- it "parses signed floats" $- property $ \n -> do- let p :: Parser Double- p = signed (hidden B.space) float- s = B8.pack (show n)- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "with scientific" $- it "parses singed scientific numbers" $- property $ \n -> do- let p = signed (hidden B.space) scientific- s = B8.pack $ 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 :: Parser Integer- p = signed (hidden B.space) decimal- n = getNonNegative n'- s = B8.pack ('+' : 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 :: Parser Integer- p = signed (hidden B.space) decimal- s = B8.pack (' ' : show (n :: Integer))- prs p s `shouldFailWith` err 0- (utok 32 <> etok 43 <> etok 45 <> 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 :: Parser Integer- p = signed (hidden B.space) decimal- s = "- 123"- prs p s `shouldParse` (-123)- prs' p s `succeedsLeaving` ""--------------------------------------------------------------------------------- Helpers--prs- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> Either (ParseErrorBundle ByteString Void) a- -- ^ Result of parsing-prs p = parse p ""--prs'- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)- -- ^ Result of parsing-prs' p s = runParser' p (initialState s)--isDigit :: Word8 -> Bool-isDigit w = w - 48 < 10--isOctDigit :: Word8 -> Bool-isOctDigit w = w - 48 < 8--isHexDigit :: Word8 -> Bool-isHexDigit w =- (w >= 48 && w <= 57) ||- (w >= 97 && w <= 102) ||- (w >= 65 && w <= 70)
− tests/Text/Megaparsec/ByteSpec.hs
@@ -1,236 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.ByteSpec (spec) where--import Control.Monad-import Data.ByteString (ByteString)-import Data.Char-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import Data.Void-import Data.Word (Word8)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc hiding (prs, prs', Parser)-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Byte-import qualified Data.ByteString as B--type Parser = Parsec Void ByteString--spec :: Spec-spec = do-- describe "newline" $- checkStrLit "newline" "\n" (tokenToChunk bproxy <$> 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 /= 10 ==> do- let s = "\r" <> B.singleton ch- prs eol s `shouldFailWith`- err 0 (utoks s <> elabel "end of line")- context "when input stream is '\\r'" $- it "signals correct parse error" $- prs eol "\r" `shouldFailWith` err 0- (utok 13 <> elabel "end of line")- context "when stream does not begin with newline or CRLF sequence" $- it "signals correct parse error" $- property $ \ch s -> (ch /= 13 && ch /= 10) ==> do- let s' = B.singleton ch <> s- prs eol s' `shouldFailWith` err 0- (utoks (B.take 2 s') <> elabel "end of line")- context "when stream is empty" $- it "signals correct parse error" $- prs eol "" `shouldFailWith` err 0- (ueof <> elabel "end of line")-- describe "tab" $- checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)-- describe "space" $- it "consumes space up to first non-space character" $- property $ \s' -> do- let (s0,s1) = B.partition isSpace' s'- s = s0 <> s1- prs space s `shouldParse` ()- prs' space s `succeedsLeaving` s1-- describe "space1" $ do- context "when stream does not start with a space character" $- it "signals correct parse error" $- property $ \ch s' -> not (isSpace' ch) ==> do- let (s0,s1) = B.partition isSpace' s'- s = B.singleton ch <> s0 <> s1- prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")- prs' space1 s `failsLeaving` s- context "when stream starts with a space character" $- it "consumes space up to first non-space character" $- property $ \s' -> do- let (s0,s1) = B.partition isSpace' s'- s = " " <> s0 <> s1- prs space1 s `shouldParse` ()- prs' space1 s `succeedsLeaving` s1- context "when stream is empty" $- it "signals correct parse error" $- prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")-- describe "controlChar" $- checkCharPred "control character" (isControl . toChar) controlChar-- describe "spaceChar" $- checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar-- describe "alphaNumChar" $- checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar-- describe "printChar" $- checkCharPred "printable character" (isPrint . toChar) printChar-- describe "digitChar" $- checkCharRange "digit" [48..57] digitChar-- describe "binDigitChar" $- checkCharRange "binary digit" [48..49] binDigitChar-- describe "octDigitChar" $- checkCharRange "octal digit" [48..55] octDigitChar-- describe "hexDigitChar" $- checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar-- describe "char'" $ do- context "when stream begins with the character specified as argument" $- it "parses the character" $- property $ \ch s -> do- let sl = B.cons (liftChar toLower ch) s- su = B.cons (liftChar toUpper ch) s- st = B.cons (liftChar toTitle ch) s- prs (char' ch) sl `shouldParse` liftChar toLower ch- prs (char' ch) su `shouldParse` liftChar toUpper ch- prs (char' ch) st `shouldParse` liftChar toTitle ch- prs' (char' ch) sl `succeedsLeaving` s- prs' (char' ch) su `succeedsLeaving` s- prs' (char' ch) st `succeedsLeaving` s- context "when stream does not begin with the character specified as argument" $- it "signals correct parse error" $- property $ \ch ch' s -> not (casei ch ch') ==> do- let s' = B.cons ch' s- ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)- prs (char' ch) s' `shouldFailWith` err 0 ms- prs' (char' ch) s' `failsLeaving` s'- context "when stream is empty" $- it "signals correct parse error" $- property $ \ch -> do- let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)- prs (char' ch) "" `shouldFailWith` err 0 ms--------------------------------------------------------------------------------- Helpers--checkStrLit :: String -> ByteString -> Parser ByteString -> 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 /= B.head ts ==> do- let s' = B.cons ch s- us = B.take (B.length ts) s'- prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)- prs' p s' `failsLeaving` s'- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)--checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith ()-checkCharPred name f p = do- context ("when stream begins with " ++ name) $- it ("parses the " ++ name) $- property $ \ch s -> f ch ==> do- let s' = B.singleton 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' = B.singleton ch <> s- prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)- prs' p s' `failsLeaving` s'- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> elabel name)--checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith ()-checkCharRange name tchs p = do- forM_ tchs $ \tch ->- context ("when stream begins with " ++ showTokens bproxy (nes tch)) $- it ("parses the " ++ showTokens bproxy (nes tch)) $- property $ \s -> do- let s' = B.singleton tch <> s- prs p s' `shouldParse` tch- prs' p s' `succeedsLeaving` s- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> elabel name)--prs- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> Either (ParseErrorBundle ByteString Void) a- -- ^ Result of parsing-prs p = parse p ""--prs'- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)- -- ^ Result of parsing-prs' p s = runParser' p (initialState s)---- | 'Word8'-specialized version of 'isSpace'.--isSpace' :: Word8 -> Bool-isSpace' x- | x >= 9 && x <= 13 = True- | x == 32 = True- | x == 160 = True- | otherwise = False---- | Lift char transformation to byte transformation.--liftChar :: (Char -> Char) -> Word8 -> Word8-liftChar f x = (fromMaybe x . fromChar . f . toChar) x---- | Compare two characters case-insensitively.--casei :: Word8 -> Word8 -> Bool-casei x y =- x == liftChar toLower y ||- x == liftChar toUpper y ||- x == liftChar toTitle y
− tests/Text/Megaparsec/Char/LexerSpec.hs
@@ -1,569 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}--module Text.Megaparsec.Char.LexerSpec (spec) where--import Control.Monad-import Data.Char hiding (ord)-import Data.List (isInfixOf)-import Data.Maybe-import Data.Monoid ((<>))-import Data.Scientific (Scientific, fromFloatDigits)-import Data.Void (Void)-import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import Text.Megaparsec.Char.Lexer-import qualified Data.CaseInsensitive as CI-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 y'- y' = toUpper <$> y- y = takeWhile (not . isSpace) s- -- Rare tricky cases we don't want to deal with.- when (CI.mk y' /= CI.mk y) discard- prs p s `shouldParse` y- prs' p s `succeedsLeaving` ""-- describe "skipLineComment" $ do- context "when there is no newline at the end of line" $- it "is picked up successfully" $ do- let p = skipLineComment "//"- s = "// this line comment doesn't have a newline at the end "- prs p s `shouldParse` ()- prs' p s `succeedsLeaving` ""- it "inner characters are labelled properly" $ do- let p = skipLineComment "//" <* empty- s = "// here we go"- prs p s `shouldFailWith` err (length s) (elabel "character")- prs' p s `failsLeaving` ""-- describe "skipBlockComment" $- it "skips a simple block comment" $ do- let p = skipBlockComment "/*" "*/"- s = "/* here we go */foo!"- prs p s `shouldParse` ()- prs' p s `succeedsLeaving` "foo!"-- 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 $ \s w o -> do- let p = do- setTabWidth w- setOffset o- indentLevel- c = sourceColumn (strSourcePos w (initialPos "") (take o s))- prs p s `shouldParse` c- prs' p s `succeedsLeaving` s-- describe "incorrectIndent" $- it "signals correct parse error" $- property $ \ord ref actual -> do- let p :: Parser ()- p = incorrectIndent ord ref actual- prs p "" `shouldFailWith` errFancy 0 (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` errFancy 0 (ii GT pos1 col0)- | col1 /= col0 ->- prs p s `shouldFailWith` errFancy (getIndent l1 + g 1) (ii EQ col0 col1)- | col2 <= col0 ->- prs p s `shouldFailWith` errFancy (getIndent l2 + g 2) (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` errFancy i (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 = mkPos . 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' = mkPos (fromIntegral ib)- if | col1 <= col0 -> prs p s `shouldFailWith`- err (getIndent l1 + g 1) (utok (head sblb) <> eeof)- | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`- errFancy (getIndent l1 + g 1) (ii EQ ib' col1)- | col2 <= col1 -> prs p s `shouldFailWith`- errFancy (getIndent l2 + g 2) (ii GT col1 col2)- | col3 == col2 -> prs p s `shouldFailWith`- err (getIndent l3 + g 3) (utoks sblb <> etoks sblc <> eeof)- | col3 <= col0 -> prs p s `shouldFailWith`- err (getIndent l3 + g 3) (utok (head sblb) <> eeof)- | col3 < col1 -> prs p s `shouldFailWith`- errFancy (getIndent l3 + g 3) (ii EQ col1 col3)- | col3 > col1 -> prs p s `shouldFailWith`- errFancy (getIndent l3 + g 3) (ii EQ col2 col3)- | col4 <= col3 -> prs p s `shouldFailWith`- errFancy (getIndent l4 + g 4) (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` ""- it "IndentSome expects the specified indentation level for first item" $ do- let s = "aaa\n bbb\n"- p = indentBlock scn $- IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla- lvlb = symbol sc sblb- l x = return . (x,)- prs p s `shouldFailWith` errFancy 6- (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3))-- 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`- errFancy (getIndent l1 + g 1) (ii GT col0 col1)- | end1 && col2 <= col0 -> prs p s `shouldFailWith`- errFancy (getIndent l2 + g 2) (ii GT col0 col2)- | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)-- describe "charLiteral" $ do- let p = charLiteral- context "when stream begins with a literal character" $- it "parses it" $- property $ \ch -> do- let 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 s = "\\"- prs p s `shouldFailWith` err 0 (utok '\\' <> elabel "literal character")- prs' p s `failsLeaving` s- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character")-#if MIN_VERSION_base(4,9,0)- context "when given a long escape sequence" $- it "parses it correctly" $- property $ \s' -> do- let s = "\\1114111\\&" ++ s'- prs p s `shouldParse` '\1114111'- prs' p s `succeedsLeaving` s'-#endif-- describe "decimal" $ do- context "when stream begins with decimal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = decimal :: Parser 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 = decimal :: Parser Integer- s = a : as- prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (decimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "integer")-- describe "binary" $ do- context "when stream begins with binary digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = binary :: Parser Integer- n = getNonNegative n'- s = showIntAtBase 2 intToDigit n ""- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "when stream does not begin with binary digits" $- it "signals correct parse error" $- property $ \a as -> a /= '0' && a /= '1' ==> do- let p = binary :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "binary integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (binary :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "binary integer")-- describe "octal" $ do- context "when stream begins with octal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = octal :: Parser Integer- 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 :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "octal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (octal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "octal integer")-- describe "hexadecimal" $ do- context "when stream begins with hexadecimal digits" $- it "they are parsed as an integer" $- property $ \n' -> do- let p = hexadecimal :: Parser Integer- 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 :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "hexadecimal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "hexadecimal integer")-- describe "scientific" $ do- context "when stream begins with a number" $- it "parses it" $- property $ \n' -> do- let p = scientific :: Parser Scientific- 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 fractional part is interrupted" $- it "signals correct parse error" $- property $ \(NonNegative n) -> do- let p = scientific <* empty :: Parser Scientific- s = showFFloatAlt Nothing (n :: Double) ""- prs p s `shouldFailWith` err (length s)- (etok 'E' <> etok 'e' <> elabel "digit")- prs' p s `failsLeaving` ""- context "when whole part is followed by a dot without valid fractional part" $- it "parsing of fractional part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = scientific :: Parser Scientific- s = showInt (n :: Integer) ".err"- prs p s `shouldParse` fromIntegral n- prs' p s `succeedsLeaving` ".err"- context "when number is followed by something starting with 'e'" $- it "parsing of exponent part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = scientific :: Parser Scientific- s = showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` fromFloatDigits n- prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (scientific :: Parser Scientific) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")-- describe "float" $ do- context "when stream begins with a float" $- it "parses it" $- property $ \n' -> do- let p = float :: Parser Double- 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 :: Parser Double- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "digit")- prs' p s `failsLeaving` s- context "when stream begins with an integer (decimal)" $- it "signals correct parse error" $- property $ \n' -> do- let p = float :: Parser Double- n = getNonNegative n'- s = show (n :: Integer)- prs p s `shouldFailWith` err (length s)- (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")- prs' p s `failsLeaving` ""- context "when number is followed by something starting with 'e'" $- it "parsing of exponent part is backtracked correctly" $- property $ \(NonNegative n) -> do- let p = float :: Parser Double- s = showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` n- prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (float :: Parser Double) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")- context "when there is float with just exponent" $- it "parses it all right" $ do- let p = float :: Parser Double- prs p "123e3" `shouldParse` 123e3- prs' p "123e3" `succeedsLeaving` ""- prs p "123e+3" `shouldParse` 123e+3- prs' p "123e+3" `succeedsLeaving` ""- prs p "123e-3" `shouldParse` 123e-3- prs' p "123e-3" `succeedsLeaving` ""-- describe "signed" $ do- context "with integer" $- it "parses signed integers" $- property $ \n -> do- let p :: Parser Integer- p = signed (hidden C.space) decimal- s = show n- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "with float" $- it "parses signed floats" $- property $ \n -> do- let p :: Parser Double- p = signed (hidden C.space) float- s = show n- prs p s `shouldParse` n- prs' p s `succeedsLeaving` ""- context "with scientific" $- it "parses singed scientific numbers" $- property $ \n -> do- let p = signed (hidden C.space) scientific- 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 :: Parser Integer- p = signed (hidden C.space) decimal- 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 :: Parser Integer- p = signed (hidden C.space) decimal- s = ' ' : show (n :: Integer)- prs p s `shouldFailWith` err 0- (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 :: Parser Integer- p = signed (hidden C.space) decimal- 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, (scaleDown . listOf1 . return) '\n')]--mkIndent' :: String -> Int -> Gen String-mkIndent' x n = concat <$> sequence [spc, sym, tra]- where- spc = frequency [(5, vectorOf n itm), (1, scaleDown (listOf itm))]- tra = scaleDown (listOf itm)- itm = elements " \t"- sym = return x--whiteChars :: Gen String-whiteChars = scaleDown $ 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 $ takeWhile1P Nothing f) empty empty- where- f x = x == ' ' || x == '\t'--scn :: Parser ()-scn = space C.space1 l b- where- l = skipLineComment "//"- b = skipBlockComment "/*" "*/"--getIndent :: String -> Int-getIndent = length . takeWhile isSpace--getCol :: String -> Pos-getCol x = sourceColumn .- strSourcePos defaultTabWidth (initialPos "") $ takeWhile isSpace x--sbla, sblb, sblc :: String-sbla = "aaa"-sblb = "bbb"-sblc = "ccc"--ii :: Ordering -> Pos -> Pos -> EF Void-ii ord ref actual = fancy (ErrorIndentation ord ref actual)
− tests/Text/Megaparsec/CharSpec.hs
@@ -1,348 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.Megaparsec.CharSpec (spec) where--import Control.Monad-import Data.Char-import Data.List (nub, partition, isPrefixOf)-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-import qualified Data.CaseInsensitive as CI--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 0 (utoks s <> elabel "end of line")- context "when input stream is '\\r'" $- it "signals correct parse error" $- prs eol "\r" `shouldFailWith` err 0- (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 0- (utoks (take 2 s') <> elabel "end of line")- context "when stream is empty" $- it "signals correct parse error" $- prs eol "" `shouldFailWith` err 0- (ueof <> elabel "end of line")-- describe "tab" $- checkStrLit "tab" "\t" (pure <$> tab)-- describe "space" $- it "consumes space 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 "space1" $ do- context "when stream does not start with a space character" $- it "signals correct parse error" $- property $ \ch s' -> not (isSpace ch) ==> do- let (s0,s1) = partition isSpace s'- s = ch : s0 ++ s1- prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")- prs' space1 s `failsLeaving` s- context "when stream starts with a space character" $- it "consumes space up to first non-space character" $- property $ \s' -> do- let (s0,s1) = partition isSpace s'- s = ' ' : s0 ++ s1- prs space1 s `shouldParse` ()- prs' space1 s `succeedsLeaving` s1- context "when stream is empty" $- it "signals correct parse error" $- prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")-- 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 "binDigitChar" $- checkCharRange "binary digit" ['0'..'1'] binDigitChar-- 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" $- checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar- 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 0 (utok 'б' <> elabel "Latin-1 character")- prs' latin1Char "в" `failsLeaving` "в"- context "when stream is empty" $- it "signals correct parse error" $- prs latin1Char "" `shouldFailWith` err 0 (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 0 (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 0 (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 0 (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 0 (ueof <> etok ch)-- describe "char'" $ do- context "when stream begins with the character specified as argument" $ do- it "parses the character" $- property $ \ch s -> do- let sl = toLower ch : s- su = toUpper ch : s- st = toTitle ch : s- prs (char' ch) sl `shouldParse` toLower ch- prs (char' ch) su `shouldParse` toUpper ch- prs (char' ch) st `shouldParse` toTitle ch- prs' (char' ch) sl `succeedsLeaving` s- prs' (char' ch) su `succeedsLeaving` s- context "when the character is not upper or lower" $- -- See https://ghc.haskell.org/trac/ghc/ticket/14589- it "matches it against a form obtained via one of the conversion functions" $- property $ \s -> do- let ch = '\9438'- s' = '\9412' : s- prs (char' ch) s' `shouldParse` '\9412'- prs' (char' ch) s' `succeedsLeaving` s- context "when stream does not begin with the character specified as argument" $ do- it "signals correct parse error" $- property $ \ch ch' s -> not (casei ch ch') ==> do- let s' = ch' : s- ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) <> etok (toTitle ch)- prs (char' ch) s' `shouldFailWith` err 0 ms- prs' (char' ch) s' `failsLeaving` s'- context "when the character is not upper or lower" $- it "lists correct options in the error message" $- property $ \ch s -> not (casei '\9438' ch) ==> do- let ms = utok ch <> etok '\9438' <> etok '\9412'- s' = ch : s- prs (char' '\9438') s' `shouldFailWith` err 0 ms- context "when stream is empty" $- it "signals correct parse error" $- property $ \ch -> do- let options = etok <$> [toLower ch, toTitle ch, toUpper ch]- ms = ueof <> mconcat (nub options)- prs (char' ch) "" `shouldFailWith` err 0 ms-- 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 us = take (length str) s- prs (string str) s `shouldFailWith` err 0 (utoks us <> 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- -- Rare tricky cases we don't want to deal with.- when (CI.mk str /= CI.mk str') discard- 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 us = take (length str) s- prs (string' str) s `shouldFailWith` err 0 (utoks us <> etoks str)--------------------------------------------------------------------------------- Helpers--checkStrLit :: String -> String -> Parser 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- us = take (length ts) s'- prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)- prs' p s' `failsLeaving` s'- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)--checkCharPred :: String -> (Char -> Bool) -> Parser 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 0 (utok ch <> elabel name)- prs' p s' `failsLeaving` s'- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> elabel name)--checkCharRange :: String -> String -> Parser Char -> SpecWith ()-checkCharRange name tchs p = do- forM_ tchs $ \tch ->- context ("when stream begins with " ++ showTokens sproxy (nes tch)) $- it ("parses the " ++ showTokens sproxy (nes tch)) $- property $ \s -> do- let s' = tch : s- prs p s' `shouldParse` tch- prs' p s' `succeedsLeaving` s- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (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---- | 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---- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y =- x == toLower y ||- x == toUpper y ||- x == toTitle y
− tests/Text/Megaparsec/DebugSpec.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.DebugSpec- ( spec )-where--import Control.Monad-import Data.Monoid ((<>))-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc-import Text.Megaparsec-import Text.Megaparsec.Char-import Text.Megaparsec.Debug--spec :: Spec-spec = do-- describe "dbg" $ do- -- NOTE We don't test properties here to avoid flood of debugging output- -- when the test runs.- context "when inner parser succeeds consuming input" $ do- it "has no effect on how parser works" $ do- let p = dbg "char" (char 'a')- s = "ab"- prs p s `shouldParse` 'a'- prs' p s `succeedsLeaving` "b"- it "its hints are preserved" $ do- let p = dbg "many chars" (many (char 'a')) <* empty- s = "abcd"- prs p s `shouldFailWith` err 1 (etok 'a')- prs' p s `failsLeaving` "bcd"- context "when inner parser fails consuming input" $- it "has no effect on how parser works" $ do- let p = dbg "chars" (char 'a' *> char 'c')- s = "abc"- prs p s `shouldFailWith` err 1 (utok 'b' <> etok 'c')- prs' p s `failsLeaving` "bc"- context "when inner parser succeeds without consuming" $ do- it "has no effect on how parser works" $ do- let p = dbg "return" (return 'a')- s = "abc"- prs p s `shouldParse` 'a'- prs' p s `succeedsLeaving` s- it "its hints are preserved" $ do- let p = dbg "many chars" (many (char 'a')) <* empty- s = "bcd"- prs p s `shouldFailWith` err 0 (etok 'a')- prs' p s `failsLeaving` "bcd"- context "when inner parser fails without consuming" $- it "has no effect on how parser works" $ do- let p = dbg "empty" (void empty)- s = "abc"- prs p s `shouldFailWith` err 0 mempty- prs' p s `failsLeaving` s
− tests/Text/Megaparsec/ErrorSpec.hs
@@ -1,280 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--module Text.Megaparsec.ErrorSpec (spec) where--import Control.Exception (Exception (..))-import Data.Functor.Identity-import Data.List (isSuffixOf, isInfixOf, sort)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Void-import Test.Hspec-import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc ()-import Test.QuickCheck-import Text.Megaparsec-import qualified Data.Semigroup as S-import qualified Data.Set as E--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid-#endif--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 "error merging with (<>)" $ do- it "selects greater offset" $- property $ \x y ->- errorOffset (x <> y :: PE) === max (errorOffset x) (errorOffset y)- context "when combining two trivial parse errors at the same position" $- it "merges their unexpected and expected items" $ do- let n Nothing Nothing = Nothing- n (Just x) Nothing = Just x- n Nothing (Just y) = Just y- n (Just x) (Just y) = Just (max x y)- property $ \pos us0 ps0 us1 ps1 ->- TrivialError pos us0 ps0 <> TrivialError pos us1 ps1 `shouldBe`- (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE)- context "when combining two fancy parse errors at the same position" $- it "merges their custom items" $- property $ \pos xs0 xs1 ->- FancyError pos xs0 <> FancyError pos xs1 `shouldBe`- (FancyError pos (E.union xs0 xs1) :: PE)- context "when combining trivial error with fancy error" $ do- it "fancy has precedence (left)" $- property $ \pos us ps xs ->- FancyError pos xs <> TrivialError pos us ps `shouldBe`- (FancyError pos xs :: PE)- it "fancy has precedence (right)" $- property $ \pos us ps xs ->- TrivialError pos us ps <> FancyError pos xs `shouldBe`- (FancyError pos xs :: PE)-- describe "errorOffset" $- it "returns error position" $- property $ \e ->- errorOffset e `shouldBe`- (case e :: PE of- TrivialError o _ _ -> o- FancyError o _ -> o)-- describe "attachSourcePos" $- it "attaches the positions correctly" $- property $ \xs' s -> do- let xs = sort $ getSmall . getPositive <$> xs'- pst = initialPosState (s :: String)- pst' =- if null xs- then pst- else snd $ reachOffsetNoLine (last xs) pst- rs = f <$> xs- f x = (x, fst (reachOffsetNoLine x pst))- attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst')-- describe "errorBundlePretty" $ do- it "shows empty line correctly" $ do- let s = "" :: String- mkBundlePE s (mempty :: PE) `shouldBe`- "1:1:\n |\n1 | <empty line>\n | ^\nunknown parse error\n"- it "shows position on first line correctly" $ do- let s = "abc" :: String- pe = err 1 (utok 'b' <> etok 'd') :: PE- mkBundlePE s pe `shouldBe`- "1:2:\n |\n1 | abc\n | ^\nunexpected 'b'\nexpecting 'd'\n"- it "skips to second line correctly" $ do- let s = "one\ntwo\n" :: String- pe = err 4 (utok 't' <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n"- it "shows position on 1000 line correctly" $ do- let s = replicate 999 '\n' ++ "abc"- pe = err 999 (utok 'a' <> etok 'd') :: PE- mkBundlePE s pe `shouldBe`- "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n"- it "shows offending line in the presence of tabs correctly" $ do- let s = "\tsomething" :: String- pe = err 1 (utok 's' <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n"- it "uses continuous highlighting properly (trivial)" $ do- let s = "\tfoobar" :: String- pe = err 1 (utoks "foo" <> utoks "rar") :: PE- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | foobar\n | ^^^\nunexpected \"rar\"\n"- it "uses continuous highlighting properly (fancy)" $ do- let s = "\tfoobar" :: String- pe = errFancy 1- (fancy $ ErrorCustom (CustomErr 5)) :: ParseError String CustomErr- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | foobar\n | ^^^^^\ncustom thing\n"- it "adjusts continuous highlighting so it doesn't get too long" $ do- let s = "foobar\n" :: String- pe = err 4 (utoks "foobar" <> etoks "foobar") :: PE- mkBundlePE s pe `shouldBe`- "1:5:\n |\n1 | foobar\n | ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n"- context "stream of insufficient size is provided in the bundle" $- it "handles the situation reasonably" $ do- let s = "" :: String- pe = err 3 (ueof <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "1:1:\n |\n1 | <empty line>\n | ^\nunexpected end of input\nexpecting 'x'\n"- context "starting column in bundle is greater than 1" $ do- context "and less than parse error column" $- it "is rendered correctly" $ do- let s = "foo" :: String- pe = err 5 (utok 'o' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 4- , pstateSourcePos = SourcePos "" pos1 (mkPos 5)- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }- errorBundlePretty bundle `shouldBe`- "1:6:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"- context "and greater than parse error column" $- it "is rendered correctly" $ do- let s = "foo" :: String- pe = err 5 (utok 'o' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 9- , pstateSourcePos = SourcePos "" pos1 (mkPos 10)- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }- errorBundlePretty bundle `shouldBe`- "1:10:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"- it "takes tab width into account correctly" $- property $ \w' -> do- let s = "\tsomething\t" :: String- pe = err 1 (utok 's' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = w'- , pstateLinePrefix = ""- }- }- w = unPos w'- tabRep = replicate w ' '- errorBundlePretty bundle `shouldBe`- ("1:" ++ show (w + 1) ++ ":\n |\n1 | " ++ tabRep ++- "something" ++ tabRep ++- "\n | " ++ tabRep ++ "^\nunexpected 's'\nexpecting 'x'\n")- it "displays multi-error bundle correctly" $ do- let s = "something\ngood\n" :: String- pe0 = err 2 (utok 'm' <> etok 'x') :: PE- pe1 = err 10 (utok 'g' <> etok 'y') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe0 :| [pe1]- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }- errorBundlePretty bundle `shouldBe`- "1:3:\n |\n1 | something\n | ^\nunexpected 'm'\nexpecting 'x'\n\n2:1:\n |\n2 | good\n | ^\nunexpected 'g'\nexpecting 'y'\n"-- describe "parseErrorPretty" $ do- it "shows unknown ParseError correctly" $- parseErrorPretty (mempty :: PE) `shouldBe` "offset=0:\nunknown parse error\n"- it "result always ends with a newline" $- property $ \x ->- parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)- it "result contains representation of offset" $- property (contains (Identity . errorOffset) show)- it "result contains unexpected/expected items" $ do- let e = err 0 (utoks "foo" <> etoks "bar" <> etoks "baz") :: PE- parseErrorPretty e `shouldBe` "offset=0:\nunexpected \"foo\"\nexpecting \"bar\" or \"baz\"\n"- it "result contains representation of custom items" $ do- let e = errFancy 0 (fancy (ErrorFail "Ooops!")) :: PE- parseErrorPretty e `shouldBe` "offset=0:\nOoops!\n"- it "several fancy errors look not so bad" $ do- let pe :: PE- pe = errFancy 0 $- mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")- parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n"-- describe "parseErrorTextPretty" $ do- it "shows trivial unknown ParseError correctly" $- parseErrorTextPretty (mempty :: PE)- `shouldBe` "unknown parse error\n"- it "shows fancy unknown ParseError correctly" $- parseErrorTextPretty (FancyError 0 E.empty :: PE)- `shouldBe` "unknown fancy parse error\n"- it "result always ends with a newline" $- property $ \x ->- parseErrorTextPretty (x :: PE)- `shouldSatisfy` ("\n" `isSuffixOf`)-- describe "displayException" $- it "produces the same result as parseErrorPretty" $- property $ \x ->- displayException x `shouldBe` parseErrorPretty (x :: PE)--------------------------------------------------------------------------------- Helpers---- | Custom error component to test continuous highlighting for custom--- components.--newtype CustomErr = CustomErr Int- deriving (Eq, Ord, Show)--instance ShowErrorComponent CustomErr where- showErrorComponent _ = "custom thing"- errorComponentLen (CustomErr n) = n--type PE = ParseError String Void--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--mkBundlePE- :: (Stream s, ShowErrorComponent e)- => s- -> ParseError s e- -> String-mkBundlePE s e = errorBundlePretty $ ParseErrorBundle- { bundleErrors = e :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }
− tests/Text/Megaparsec/PosSpec.hs
@@ -1,63 +0,0 @@-module Text.Megaparsec.PosSpec (spec) where--import Control.Exception (evaluate)-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--spec :: Spec-spec = do-- describe "mkPos" $ do- context "when the argument is a non-positive number" $- it "throws InvalidPosException" $- property $ \n -> n <= 0 ==>- evaluate (mkPos n) `shouldThrow` (== InvalidPosException n)- context "when the argument is not 0" $- it "returns Pos with the given value" $- property $ \n ->- (n > 0) ==> (unPos (mkPos n) `shouldBe` 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 === mkPos (unPos x + unPos y) .&&.- unPos (x <> y) === unPos x + unPos y-- describe "initialPos" $- it "constructs initial position correctly" $- property $ \path ->- let x = initialPos path- in sourceName x === path .&&.- sourceLine x === mkPos 1 .&&.- sourceColumn x === mkPos 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
− tests/Text/Megaparsec/StreamSpec.hs
@@ -1,550 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Text.Megaparsec.StreamSpec (spec) where--import Control.Monad-import Data.Char (isLetter, chr, isControl, isSpace)-import Data.List (foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Proxy-import Data.Semigroup ((<>))-import Data.String (IsString)-import Data.Word (Word8)-import Test.Hspec-import Test.Hspec.Megaparsec.AdHoc-import Test.QuickCheck-import Text.Megaparsec-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--spec :: Spec-spec = do-- describe "String instance of Stream" $ do- describe "tokenToChunk" $- it "produces the same result as singleton with tokensToChunk" $- property $ \ch ->- tokenToChunk sproxy ch === tokensToChunk sproxy [ch]- describe "tokensToChunk" $- it "list of tokens is isomorphic to chunk" $- property $ \ts ->- chunkToTokens sproxy (tokensToChunk sproxy ts) === ts- describe "chunkToTokens" $- it "chunk is isomorphic to list of tokens" $- property $ \chk ->- tokensToChunk sproxy (chunkToTokens sproxy chk) === chk- describe "chunkLength" $- it "returns correct length of given chunk" $- property $ \chk ->- chunkLength sproxy chk === length chk- describe "chunkEmpty" $- it "only true when chunkLength returns 0" $- property $ \chk ->- chunkEmpty sproxy chk === (chunkLength sproxy chk <= 0)- describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: String) === Nothing- context "when input is not empty" $- it "unconses a token" $- property $ \s -> not (null s) ==>- take1_ (s :: String) === Just (head s, tail s)- describe "takeN_" $ do- context "requested length is 0" $- it "returns Just empty chunk and original stream" $- property $ \s ->- takeN_ 0 (s :: String) === Just ("", s)- context "requested length is greater than 0" $ do- context "stream is empty" $- it "returns Nothing" $- property $ \(Positive n) ->- takeN_ n ("" :: String) === Nothing- context "stream is not empty" $- it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (null s) ==>- takeN_ n (s :: String) === Just (splitAt n s)- describe "takeWhile_" $- it "extracts a chunk that is a prefix consisting of matching tokens" $- property $ \s ->- takeWhile_ isLetter s === span isLetter s- describeShowTokens sproxy quotedCharGen- describeReachOffset sproxy- describeReachOffsetNoLine sproxy-- describe "ByteString instance of Stream" $ do- describe "tokenToChunk" $- it "produces the same result as singleton with tokensToChunk" $- property $ \ch ->- tokenToChunk bproxy ch === tokensToChunk bproxy [ch]- describe "tokensToChunk" $- it "list of tokens is isomorphic to chunk" $- property $ \ts ->- chunkToTokens bproxy (tokensToChunk bproxy ts) === ts- describe "chunkToTokens" $- it "chunk is isomorphic to list of tokens" $- property $ \chk ->- tokensToChunk bproxy (chunkToTokens bproxy chk) === chk- describe "chunkLength" $- it "returns correct length of given chunk" $- property $ \chk ->- chunkLength bproxy chk === B.length chk- describe "chunkEmpty" $- it "only true when chunkLength returns 0" $- property $ \chk ->- chunkEmpty bproxy chk === (chunkLength bproxy chk <= 0)- describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: B.ByteString) === Nothing- context "when input is not empty" $- it "unconses a token" $- property $ \s -> not (B.null s) ==>- take1_ (s :: B.ByteString) === B.uncons s- describe "takeN_" $ do- context "requested length is 0" $- it "returns Just empty chunk and original stream" $- property $ \s ->- takeN_ 0 (s :: B.ByteString) === Just ("", s)- context "requested length is greater than 0" $ do- context "stream is empty" $- it "returns Nothing" $- property $ \(Positive n) ->- takeN_ n ("" :: B.ByteString) === Nothing- context "stream is not empty" $- it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (B.null s) ==>- takeN_ n (s :: B.ByteString) === Just (B.splitAt n s)- describe "takeWhile_" $- it "extracts a chunk that is a prefix consisting of matching tokens" $- property $ \s ->- let f = isLetter . chr . fromIntegral- in takeWhile_ f s === B.span f s- describeShowTokens bproxy quotedWordGen- describeReachOffset bproxy- describeReachOffsetNoLine bproxy-- describe "Lazy ByteString instance of Stream" $ do- describe "tokenToChunk" $- it "produces the same result as singleton with tokensToChunk" $- property $ \ch ->- tokenToChunk blproxy ch === tokensToChunk blproxy [ch]- describe "tokensToChunk" $- it "list of tokens is isomorphic to chunk" $- property $ \ts ->- chunkToTokens blproxy (tokensToChunk blproxy ts) === ts- describe "chunkToTokens" $- it "chunk is isomorphic to list of tokens" $- property $ \chk ->- tokensToChunk blproxy (chunkToTokens blproxy chk) === chk- describe "chunkLength" $- it "returns correct length of given chunk" $- property $ \chk ->- chunkLength blproxy chk === fromIntegral (BL.length chk)- describe "chunkEmpty" $- it "only true when chunkLength returns 0" $- property $ \chk ->- chunkEmpty blproxy chk === (chunkLength blproxy chk <= 0)- describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: BL.ByteString) === Nothing- context "when input is not empty" $- it "unconses a token" $- property $ \s -> not (BL.null s) ==>- take1_ (s :: BL.ByteString) === BL.uncons s- describe "takeN_" $ do- context "requested length is 0" $- it "returns Just empty chunk and original stream" $- property $ \s ->- takeN_ 0 (s :: BL.ByteString) === Just ("", s)- context "requested length is greater than 0" $ do- context "stream is empty" $- it "returns Nothing" $- property $ \(Positive n) ->- takeN_ n ("" :: BL.ByteString) === Nothing- context "stream is not empty" $- it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (BL.null s) ==>- takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s)- describe "takeWhile_" $- it "extracts a chunk that is a prefix consisting of matching tokens" $- property $ \s ->- let f = isLetter . chr . fromIntegral- in takeWhile_ f s === BL.span f s- describeShowTokens blproxy quotedWordGen- describeReachOffset blproxy- describeReachOffsetNoLine blproxy-- describe "Text instance of Stream" $ do- describe "tokenToChunk" $- it "produces the same result as singleton with tokensToChunk" $- property $ \ch ->- tokenToChunk tproxy ch === tokensToChunk tproxy [ch]- describe "tokensToChunk" $- it "list of tokens is isomorphic to chunk" $- property $ \ts ->- chunkToTokens tproxy (tokensToChunk tproxy ts) === ts- describe "chunkToTokens" $- it "chunk is isomorphic to list of tokens" $- property $ \chk ->- tokensToChunk tproxy (chunkToTokens tproxy chk) === chk- describe "chunkLength" $- it "returns correct length of given chunk" $- property $ \chk ->- chunkLength tproxy chk === T.length chk- describe "chunkEmpty" $- it "only true when chunkLength returns 0" $- property $ \chk ->- chunkEmpty tproxy chk === (chunkLength tproxy chk <= 0)- describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: T.Text) === Nothing- context "when input is not empty" $- it "unconses a token" $- property $ \s -> not (T.null s) ==>- take1_ (s :: T.Text) === T.uncons s- describe "takeN_" $ do- context "requested length is 0" $- it "returns Just empty chunk and original stream" $- property $ \s ->- takeN_ 0 (s :: T.Text) === Just ("", s)- context "requested length is greater than 0" $ do- context "stream is empty" $- it "returns Nothing" $- property $ \(Positive n) ->- takeN_ n ("" :: T.Text) === Nothing- context "stream is not empty" $- it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (T.null s) ==>- takeN_ n (s :: T.Text) === Just (T.splitAt n s)- describe "takeWhile_" $- it "extracts a chunk that is a prefix consisting of matching tokens" $- property $ \s ->- takeWhile_ isLetter s === T.span isLetter s- describeShowTokens tproxy quotedCharGen- describeReachOffset tproxy- describeReachOffsetNoLine tproxy-- describe "Lazy Text instance of Stream" $ do- describe "tokenToChunk" $- it "produces the same result as singleton with tokensToChunk" $- property $ \ch ->- tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch]- describe "tokensToChunk" $- it "list of tokens is isomorphic to chunk" $- property $ \ts ->- chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts- describe "chunkToTokens" $- it "chunk is isomorphic to list of tokens" $- property $ \chk ->- tokensToChunk tlproxy (chunkToTokens tlproxy chk) === chk- describe "chunkLength" $- it "returns correct length of given chunk" $- property $ \chk ->- chunkLength tlproxy chk === fromIntegral (TL.length chk)- describe "chunkEmpty" $- it "only true when chunkLength returns 0" $- property $ \chk ->- chunkEmpty tlproxy chk === (chunkLength tlproxy chk <= 0)- describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: TL.Text) === Nothing- context "when input is not empty" $- it "unconses a token" $- property $ \s -> not (TL.null s) ==>- take1_ (s :: TL.Text) === TL.uncons s- describe "takeN_" $ do- context "requested length is 0" $- it "returns Just empty chunk and original stream" $- property $ \s ->- takeN_ 0 (s :: TL.Text) === Just ("", s)- context "requested length is greater than 0" $ do- context "stream is empty" $- it "returns Nothing" $- property $ \(Positive n) ->- takeN_ n ("" :: TL.Text) === Nothing- context "stream is not empty" $- it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (TL.null s) ==>- takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s)- describe "takeWhile_" $- it "extracts a chunk that is a prefix consisting of matching tokens" $- property $ \s ->- takeWhile_ isLetter s === TL.span isLetter s- describeShowTokens tlproxy quotedCharGen- describeReachOffset tlproxy- describeReachOffsetNoLine tlproxy--------------------------------------------------------------------------------- Helpers---- | Generic block of tests for the 'showTokens' method.--describeShowTokens- :: forall s. ( Stream s- , IsString (Tokens s)- , Show (Token s)- , Arbitrary (Token s)- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Gen (Token s) -- ^ Generator of tokens that should be simply quoted- -> Spec-describeShowTokens pxy quotedTokGen =- describe "showTokens" $ do- let f :: Tokens s -> String -> Expectation- f x y = showTokens pxy (NE.fromList $ chunkToTokens pxy x) `shouldBe` y- it "shows CRLF newline correctly"- (f "\r\n" "crlf newline")- it "shows null byte correctly"- (f "\NUL" "null")- it "shows start of heading correctly"- (f "\SOH" "start of heading")- it "shows start of text correctly"- (f "\STX" "start of text")- it "shows end of text correctly"- (f "\ETX" "end of text")- it "shows end of transmission correctly"- (f "\EOT" "end of transmission")- it "shows enquiry correctly"- (f "\ENQ" "enquiry")- it "shows acknowledge correctly"- (f "\ACK" "acknowledge")- it "shows bell correctly"- (f "\BEL" "bell")- 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")- it "shows carriage return correctly"- (f "\r" "carriage return")- it "shows shift out correctly"- (f "\SO" "shift out")- it "shows shift in correctly"- (f "\SI" "shift in")- it "shows data link escape correctly"- (f "\DLE" "data link escape")- it "shows device control one correctly"- (f "\DC1" "device control one")- it "shows device control two correctly"- (f "\DC2" "device control two")- it "shows device control three correctly"- (f "\DC3" "device control three")- it "shows device control four correctly"- (f "\DC4" "device control four")- it "shows negative acknowledge correctly"- (f "\NAK" "negative acknowledge")- it "shows synchronous idle correctly"- (f "\SYN" "synchronous idle")- it "shows end of transmission block correctly"- (f "\ETB" "end of transmission block")- it "shows cancel correctly"- (f "\CAN" "cancel")- it "shows end of medium correctly"- (f "\EM" "end of medium")- it "shows substitute correctly"- (f "\SUB" "substitute")- it "shows escape correctly"- (f "\ESC" "escape")- it "shows file separator correctly"- (f "\FS" "file separator")- it "shows group separator correctly"- (f "\GS" "group separator")- it "shows record separator correctly"- (f "\RS" "record separator")- it "shows unit separator correctly"- (f "\US" "unit separator")- it "shows delete correctly"- (f "\DEL" "delete")- 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 $ forAll quotedTokGen $ \x -> do- let r = showTokens pxy (x :| [])- head r `shouldBe` '\''- last r `shouldBe` '\''- it "shows strings in double quotes" $- property $ \x (NonEmpty xs) -> do- let r = showTokens pxy (x :| xs)- when (r == "crlf newline") discard- head r `shouldBe` '\"'- last r `shouldBe` '\"'- it "shows control characters in long strings property"- (f "{\n" "\"{<newline>\"")---- | Generic block of tests for the 'reachOffset' method.--describeReachOffset- :: forall s. ( Stream s- , IsString s- , Show s- , Arbitrary s- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Spec-describeReachOffset Proxy =- describe "reachOffset" $ do- it "returns correct SourcePos (newline)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\n" :: s- }- o = pstateOffset pst + 1- (r, _, _) = reachOffset o pst- SourcePos n l _ = pstateSourcePos pst- r `shouldBe` SourcePos n (l <> pos1) pos1- it "returns correct SourcePos (tab)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\t" :: s- }- o = pstateOffset pst + 1- (r, _, _) = reachOffset o pst- SourcePos n l c = pstateSourcePos pst- w = pstateTabWidth pst- r `shouldBe` SourcePos n l (toNextTab w c)- it "returns correct SourcePos (other)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "a" :: s- }- o = pstateOffset pst + 1- (r, _, _) = reachOffset o pst- SourcePos n l c = pstateSourcePos pst- r `shouldBe` SourcePos n l (c <> pos1)- it "replaces empty line with <empty line>" $- property $ \o pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "" :: s- , pstateLinePrefix = ""- }- (_, r, _) = reachOffset o pst- r `shouldBe` "<empty line>"- it "replaces tabs with spaces in returned line" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\ta\t" :: s- , pstateLinePrefix = "\t"- }- (_, r, _) = reachOffset 2 pst- w = unPos (pstateTabWidth pst)- r' = replicate (w * 2) ' ' ++ "a" ++ replicate w ' '- r `shouldBe` r'- it "returns correct line (with line prefix)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "foo\nbar\nbaz" :: s- , pstateLinePrefix = "123"- }- (_, r, _) = reachOffset 0 pst- r `shouldBe` "123foo"- it "returns correct line (without line prefix)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "foo\nbar\nbaz" :: s- , pstateOffset = 0- }- (_, r, _) = reachOffset 4 pst- r `shouldBe` "bar"- it "works incrementally" $- property $ \os' (NonNegative d) s -> do- let os = getNonNegative <$> os'- s' :: PosState String- s' = foldl' f s os- o' = case os of- [] -> d- xs -> maximum xs + d- f pst o =- let (_, _, pst') = reachOffset o pst- in pst'- reachOffset o' s `shouldBe` reachOffset o' s'---- | Generic block of tests for the 'reachOffsetNoLine' method.--describeReachOffsetNoLine- :: forall s. ( Stream s- , IsString s- , Show s- , Arbitrary s- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Spec-describeReachOffsetNoLine Proxy =- describe "reachOffsetNoLine" $ do- it "returns correct SourcePos (newline)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\n" :: s- }- o = pstateOffset pst + 1- (r, _) = reachOffsetNoLine o pst- SourcePos n l _ = pstateSourcePos pst- r `shouldBe` SourcePos n (l <> pos1) pos1- it "returns correct SourcePos (tab)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\t" :: s- }- o = pstateOffset pst + 1- (r, _) = reachOffsetNoLine o pst- SourcePos n l c = pstateSourcePos pst- w = pstateTabWidth pst- r `shouldBe` SourcePos n l (toNextTab w c)- it "returns correct SourcePos (other)" $- property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "a" :: s- }- o = pstateOffset pst + 1- (r, _) = reachOffsetNoLine o pst- SourcePos n l c = pstateSourcePos pst- r `shouldBe` SourcePos n l (c <> pos1)- it "works incrementally" $- property $ \os' (NonNegative d) s -> do- let os = getNonNegative <$> os'- s' :: PosState String- s' = foldl' f s os- o' = case os of- [] -> d- xs -> maximum xs + d- f pst o =- let (_, pst') = reachOffsetNoLine o pst- in pst'- reachOffsetNoLine o' s `shouldBe` reachOffsetNoLine o' s'---- | Get next tab position given tab width and current column.--toNextTab- :: Pos -- ^ Tab width- -> Pos -- ^ Current column- -> Pos -- ^ Column of next tab position-toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w)- where- w = unPos w'- c = unPos c'--quotedCharGen :: Gen Char-quotedCharGen = arbitrary `suchThat` isQuotedChar--quotedWordGen :: Gen Word8-quotedWordGen = arbitrary `suchThat` (isQuotedChar . toChar)---- | Return 'True' if the 'Char' should be simply quoted by the 'showTokens'--- method, i.e. it's not a character with a special representation.--isQuotedChar :: Char -> Bool-isQuotedChar x = not (isControl x) && not (isSpace x)
− tests/Text/MegaparsecSpec.hs
@@ -1,1651 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.MegaparsecSpec (spec) where--import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (toUpper, isLetter)-import Data.Foldable (asum)-import Data.List (isPrefixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup-import Data.String-import Data.Void-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-import Text.Megaparsec.Char-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 as BS-import qualified Data.List as DL-import qualified Data.Semigroup as G-import qualified Data.Set as E-import qualified Data.Text as T--#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 "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 IsString instance" $ do- describe "equivalence to 'string'" $ do- it "for String" $ property $ \s i ->- eqParser- (chunk s)- (fromString s)- (i :: String)- it "for Text" $ property $ \s i ->- eqParser- (chunk (T.pack s))- (fromString s)- (i :: T.Text)- it "for ByteString" $ property $ \s i ->- eqParser- (chunk (fromString s :: BS.ByteString))- (fromString s)- (i :: BS.ByteString)- it "can handle Unicode" $ do- let- r = "פּאַרסער 解析器" :: BS.ByteString- p :: Parsec Void BS.ByteString BS.ByteString- p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"]- parse p "" r `shouldParse` r-- 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 2 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 = chunk s0 <|> chunk 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- z = take (max (length s0) (length s1)) s- prs p s `shouldFailWith` err 0- (etoks s0 <>- etoks s1 <>- (if null s then ueof else utoks z))- 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 1 (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 0 (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 0 (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 0- (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 (ParseErrorBundle String Void) ())- v = runParserT p "" ("" :: String)- 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 0 (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 0 (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 Void String ()- prs p "" `shouldFailWith` errFancy 0 (fancy $ ErrorFail 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` errFancy 0 (fancy $ ErrorFail msg)- prs' p s `failsLeaving` s-- describe "ParsecT MonadIO instance" $- it "liftIO works" $- property $ \n -> do- let p = liftIO (return n) :: ParsecT Void String IO Integer- runParserT p "" "" `shouldReturn` Right n-- describe "ParsecT MonadFix instance" $- it "withRange works" $ do- let- withRange- :: (MonadParsec e s m, MonadFix m)- => ((SourcePos,SourcePos) -> m a)- -> m a- withRange f = do- p1 <- getSourcePos- rec- r <- f (p1, p2)- p2 <- getSourcePos- return r- p :: Parsec Void String (SourcePos,SourcePos)- p = withRange $ \pp -> pp <$ string "ab"- runParser p "" "abcd"- `shouldBe` Right- ( SourcePos "" (mkPos 1) (mkPos 1)- , SourcePos "" (mkPos 1) (mkPos 3)- )-- describe "ParsecT MonadReader instance" $ do-- describe "ask" $- it "returns correct value of context" $- property $ \n -> do- let p = ask :: ParsecT Void 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 Void 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 Void 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 Void 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 Void String (Cont (Either (ParseErrorBundle String Void) 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 Void 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 Void 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 "failure" $- it "signals correct parse error" $- property $ \us ps -> do- let p :: MonadParsec Void String m => m ()- p = void (failure us ps)- grs p "" (`shouldFailWith` TrivialError 0 us ps)-- describe "fancyFailure" $- it "singals correct parse error" $- property $ \xs -> do- let p :: MonadParsec Void String m => m ()- p = void (fancyFailure xs)- grs p "" (`shouldFailWith` FancyError 0 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 Void String m => m Char- p = label lbl (char a) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` "")- context "inner parser produces hints" $- it "does not alter the hints" $- property $ \lbl a -> not (null lbl) ==> do- let p :: MonadParsec Void String m => m String- p = label lbl (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 (etok a))- grs' p s (`failsLeaving` "")- context "when inner parser consumes and fails" $- it "reports parse error without modification" $- property $ \lbl a b c -> not (null lbl) && b /= c ==> do- let p :: MonadParsec Void String m => m Char- p = label lbl (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` [c])- context "when inner parser succeeds without consuming" $ 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 Void String m => m Char- p = label lbl (return a) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "inner parser produces hints" $- it "replaces the last hint with given label" $- property $ \lbl a -> not (null lbl) ==> do- let p :: MonadParsec Void String m => m String- p = label lbl (many (char a)) <* empty- grs p "" (`shouldFailWith` err 0 (elabel lbl))- context "when inner parser fails without consuming" $- it "is mentioned in parse error via its label" $- property $ \lbl -> not (null lbl) ==> do- let p :: MonadParsec Void String m => m ()- p = label lbl empty- grs p "" (`shouldFailWith` err 0 (elabel lbl))-- describe "hidden" $ do- context "when inner parser succeeds consuming input" $ do- context "inner parser does not produce any hints" $- it "collection of hints remains empty" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = hidden (char a) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` "")- context "inner parser produces hints" $- it "hides the parser in the error message" $- property $ \a -> do- let p :: MonadParsec Void String m => m String- p = hidden (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` "")- context "when inner parser consumes and fails" $- it "reports parse error without modification" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m Char- p = hidden (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` [c])- context "when inner parser succeeds without consuming" $ do- context "inner parser does not produce any hints" $- it "collection of hints remains empty" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = hidden (return a) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "inner parser produces hints" $- it "hides the parser in the error message" $- property $ \a -> do- let p :: MonadParsec Void String m => m String- p = hidden (many (char a)) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "when inner parser fails without consuming" $- it "hides the parser in the error message" $ do- let p :: MonadParsec Void String m => m ()- p = hidden empty- grs p "" (`shouldFailWith` err 0 mempty)-- describe "try" $ do- context "when inner parser succeeds consuming" $- it "try has no effect" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = try (char a)- s = [a]- grs p s (`shouldParse` a)- grs' p s (`succeedsLeaving` "")- context "when inner parser fails consuming" $ do- it "backtracks, it appears as if the parser has not consumed anything" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m Char- p = try (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` s)- it "hints from the inner parse error do not leak" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m (Maybe Char)- p = (optional . try) (char a *> char b) <* empty- s = [a,c]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser succeeds without consuming" $- it "try has no effect" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = try (return a)- grs p "" (`shouldParse` a)- context "when inner parser fails without consuming" $- it "try backtracks parser state anyway" $- property $ \w -> do- let p :: MonadParsec Void String m => m Char- p = try (setTabWidth w *> empty)- grs p "" (`shouldFailWith` err 0 mempty)- grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)-- describe "lookAhead" $ do- context "when inner parser succeeds consuming" $ do- it "result is returned but parser state is not changed" $- property $ \a w -> do- let p :: MonadParsec Void String m => m Pos- p = lookAhead (setTabWidth w *> char a) *> getTabWidth- s = [a]- grs p s (`shouldParse` defaultTabWidth)- grs' p s (`succeedsLeaving` s)- it "hints are not preserved" $- property $ \a -> do- let p :: MonadParsec Void String m => m String- p = lookAhead (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser fails consuming" $- it "error message is reported as usual" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m Char- p = lookAhead (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` [c])- context "when inner parser succeeds without consuming" $ do- it "result is returned but parser state in not changed" $- property $ \a w -> do- let p :: MonadParsec Void String m => m Pos- p = lookAhead (setTabWidth w *> char a) *> getTabWidth- s = [a]- grs p s (`shouldParse` defaultTabWidth)- grs' p s (`succeedsLeaving` s)- it "hints are not preserved" $- property $ \a b -> a /= b ==> do- let p :: MonadParsec Void String m => m String- p = lookAhead (many (char a)) <* empty- s = [b]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser fails without consuming" $- it "error message is reported as usual" $ do- let p :: MonadParsec Void String m => m Char- p = lookAhead empty- grs p "" (`shouldFailWith` err 0 mempty)-- describe "notFollowedBy" $ do- context "when inner parser succeeds consuming" $- it "signals correct parse error" $- property $ \a w -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w <* char a)- s = [a]- grs p s (`shouldFailWith` err 0 (utok a))- grs' p s (`failsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- context "when inner parser fails consuming" $ do- it "succeeds without consuming" $- property $ \a b c w -> b /= c ==> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w *> char a *> char b)- s = [a,c]- grs' p s (`succeedsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- it "hints are not preserved" $- property $ \a b -> a /= b ==> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (char b *> many (char a) <* char a) <* empty- s = [b,b]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser succeeds without consuming" $- it "signals correct parse error" $- property $ \a w -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w *> return a)- s = [a]- grs p s (`shouldFailWith` err 0 (utok a))- grs' p s (`failsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- context "when inner parser fails without consuming" $ do- it "succeeds without consuming" $- property $ \w -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w *> empty)- grs p "" (`shouldParse` ())- grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)- it "hints are not preserved" $- property $ \a -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (many (char a) <* char a) <* empty- s = ""- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)-- describe "withRecovery" $ do- context "when inner parser succeeds consuming" $- it "the result is returned as usual" $- property $ \a as -> do- let p :: MonadParsec Void String m => m (Maybe Char)- p = withRecovery (const $ return Nothing) (pure <$> char a)- s = a : as- grs p s (`shouldParse` Just a)- grs' p s (`succeedsLeaving` as)- context "when inner parser fails consuming" $ do- context "when recovering parser succeeds consuming input" $ do- it "its result is returned and position is advanced" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ string (c : as))- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))- grs' p s (`succeedsLeaving` "")- it "hints are not preserved" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ string (c : as))- (Right <$> char a <* many (char b) <* char b) <* empty- s = a : c : as- grs p s (`shouldFailWith` err (length s) mempty)- grs' p s (`failsLeaving` "")- context "when recovering parser fails consuming input" $- it "the original parse error (and state) is reported" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ char c <* empty)- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` (c : as))- context "when recovering parser succeeds without consuming" $ do- it "its result is returned (and state)" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left) (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))- grs' p s (`succeedsLeaving` (c : as))- it "original hints are preserved" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left)- (Right <$> char a <* many (char b) <* char b) <* empty- s = a : c : as- grs p s (`shouldFailWith` err 1 (etok b))- grs' p s (`failsLeaving` (c:as))- context "when recovering parser fails without consuming" $- it "the original parse error (and state) is reported" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ empty)- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` (c : as))- context "when inner parser succeeds without consuming" $- it "the result is returned as usual" $- property $ \a s -> do- let p :: MonadParsec Void String m => m (Maybe Char)- p = withRecovery (const $ return Nothing) (return a)- grs p s (`shouldParse` a)- grs' p s (`succeedsLeaving` s)- context "when inner parser fails without consuming" $ do- context "when recovering parser succeeds consuming input" $- it "its result is returned and position is advanced" $- property $ \a as -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ string s) empty- s = a : as- grs p s (`shouldParse` Left (err 0 mempty))- grs' p s (`succeedsLeaving` "")- context "when recovering parser fails consuming input" $- it "the original parse error (and state) is reported" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ char a <* char b <* empty)- (Right <$> empty)- s = a : as- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when recovering parser succeeds without consuming" $ do- it "its result is returned (and state)" $- property $ \s -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left) empty- grs p s (`shouldParse` Left (err 0 mempty))- grs' p s (`succeedsLeaving` s)- it "original hints are preserved" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) String)- p = withRecovery (return . Left)- (Right <$> many (char a) <* empty) <* empty- s = b : as- grs p s (`shouldFailWith` err 0 (etok a))- grs' p s (`failsLeaving` s)- context "when recovering parser fails without consuming" $- it "the original parse error (and state) is reported" $- property $ \s -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ empty) empty- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- it "works in complex situations too" $- property $ \a' b' c' -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) String)- p = let g = count' 1 3 . char in v <$>- withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'- v (Right x) y = Right (x ++ y)- v (Left m) _ = Left m- ma = if a < 3 then etok 'a' else mempty- s = abcRow a b c- [a,b,c] = getNonNegative <$> [a',b',c']- f = flip shouldFailWith- z = flip shouldParse- r | a == 0 && b == 0 && c == 0 = f (err 0 (ueof <> etok 'a'))- | a == 0 && b == 0 && c > 3 = f (err 0 (utok 'c' <> etok 'a'))- | a == 0 && b == 0 = f (err 0 (utok 'c' <> etok 'a'))- | a == 0 && b > 3 = f (err 3 (utok 'b' <> etok 'c'))- | a == 0 && c == 0 = f (err b (ueof <> etok 'c'))- | a == 0 && c > 3 = f (err (b + 3) (utok 'c' <> eeof))- | a == 0 = z (Left (err 0 (utok 'b' <> etok 'a')))- | a > 3 = f (err 3 (utok 'a' <> etok 'c'))- | b == 0 && c == 0 = f (err a (ueof <> etok 'c' <> ma))- | b == 0 && c > 3 = f (err (a + 3) (utok 'c' <> eeof))- | b == 0 = z (Right s)- | otherwise = f (err a (utok 'b' <> etok 'c' <> ma))- grs (p <* eof) s r-- describe "observing" $ do- context "when inner parser succeeds consuming" $- it "returns its result in Right" $- property $ \a as -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (char a)- s = a : as- grs p s (`shouldParse` Right a)- grs' p s (`succeedsLeaving` as)- context "when inner parser fails consuming" $ do- it "returns its parse error in Left preserving state" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (char a *> char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))- grs' p s (`succeedsLeaving` (c:as))- it "does not create any hints" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (char a *> char b) *> empty- s = a : c : as- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` (c:as))- context "when inner parser succeeds without consuming" $- it "returns its result in Right" $- property $ \a s -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (return a)- grs p s (`shouldParse` Right a)- grs' p s (`succeedsLeaving` s)- context "when inner parser fails without consuming" $ do- it "returns its parse error in Left preserving state" $- property $ \s -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) ())- p = observing empty- grs p s (`shouldParse` Left (err 0 mempty))- grs' p s (`succeedsLeaving` s)- it "creates correct hints" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (char a) <* empty- s = b : as- grs p s (`shouldFailWith` err 0 (etok a))- grs' p s (`failsLeaving` (b:as))-- describe "eof" $ do- context "when input stream is empty" $- it "succeeds" $- grs eof "" (`shouldParse` ())- context "when input stream is not empty" $- it "signals correct error message" $- property $ \a as -> do- let s = a : as- grs eof s (`shouldFailWith` err 0 (utok a <> eeof))- grs' eof s (`failsLeaving` s)-- describe "token" $ do- let expected = E.singleton . Tokens . nes- testChar a x = if a == x then Just x else Nothing- context "when supplied predicate is satisfied" $- it "succeeds" $- property $ \a as -> do- let p :: MonadParsec Void String m => m Char- p = token (testChar a) (expected a)- s = a : as- grs p s (`shouldParse` a)- grs' p s (`succeedsLeaving` as)- context "when supplied predicate is not satisfied" $- it "signals correct parse error" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m Char- p = token (testChar b) (expected b)- s = a : as- us = pure (Tokens $ nes a)- ps = E.singleton (Tokens $ nes b)- grs p s (`shouldFailWith` TrivialError 0 us ps)- grs' p s (`failsLeaving` s)- context "when stream is empty" $- it "signals correct parse error" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = token (testChar a) ps- us = pure EndOfInput- ps = expected a- grs p "" (`shouldFailWith` TrivialError 0 us ps)-- describe "tokens" $ do- context "when stream is prefixed with given string" $- it "parses the string" $- property $ \str s -> do- let p :: MonadParsec Void String m => m String- p = tokens (==) str- s' = str ++ s- grs p s' (`shouldParse` str)- grs' p 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 p :: MonadParsec Void String m => m String- p = tokens (==) str- z = take (length str) s- grs p s (`shouldFailWith` err 0 (utoks z <> etoks str))- grs' p s (`failsLeaving` s)- context "when matching the empty string" $- it "eok continuation is used" $- property $ \str s -> do- let p :: MonadParsec Void String m => m String- p = (tokens (==) "" <* empty) <|> pure str- grs p s (`shouldParse` str)- grs' p s (`succeedsLeaving` s)-- describe "takeWhileP" $ do- context "when stream is not empty" $- it "consumes all matching tokens, zero or more" $- property $ \s -> not (null s) ==> do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing isLetter- (z,zs) = DL.span isLetter s- grs p s (`shouldParse` z)- grs' p s (`succeedsLeaving` zs)- context "when stream is empty" $- it "succeeds returning empty chunk" $ do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing isLetter- grs p "" (`shouldParse` "")- grs' p "" (`succeedsLeaving` "")- context "with two takeWhileP in a row (testing hints)" $ do- let p :: MonadParsec Void String m => m String- p = do- void $ takeWhileP (Just "foo") (== 'a')- void $ takeWhileP (Just "bar") (== 'b')- empty- context "when the second one does not consume" $- it "hints are combined properly" $ do- let s = "aaa"- pe = err 3 (elabel "foo" <> elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "when the second one consumes" $- it "only hints of the second one affect parse error" $ do- let s = "aaabbb"- pe = err 6 (elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "without label (testing hints)" $- it "there are no hints" $ do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing (== 'a') <* empty- s = "aaa"- grs p s (`shouldFailWith` err 3 mempty)- grs' p s (`failsLeaving` "")-- describe "takeWhile1P" $ do- context "when stream is prefixed with matching tokens" $- it "consumes the tokens" $- property $ \s' -> do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing isLetter- s = 'a' : s'- (z,zs) = DL.span isLetter s- grs p s (`shouldParse` z)- grs' p s (`succeedsLeaving` zs)- context "when stream is not prefixed with at least one matching token" $- it "signals correct parse error" $- property $ \s' -> do- let p :: MonadParsec Void String m => m String- p = takeWhile1P (Just "foo") isLetter- s = '3' : s'- pe = err 0 (utok '3' <> elabel "foo")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` s)- context "when stream is empty" $ do- context "with label" $- it "signals correct parse error" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P (Just "foo") isLetter- pe = err 0 (ueof <> elabel "foo")- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "without label" $- it "signals correct parse error" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing isLetter- pe = err 0 ueof- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "with two takeWhile1P in a row (testing hints)" $ do- let p :: MonadParsec Void String m => m String- p = do- void $ takeWhile1P (Just "foo") (== 'a')- void $ takeWhile1P (Just "bar") (== 'b')- empty- context "when the second one does not consume" $- it "hints are combined properly" $ do- let s = "aaa"- pe = err 3 (ueof <> elabel "foo" <> elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "when the second one consumes" $- it "only hints of the second one affect parse error" $ do- let s = "aaabbb"- pe = err 6 (elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "without label (testing hints)" $- it "there are no hints" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing (== 'a') <* empty- s = "aaa"- grs p s (`shouldFailWith` err 3 mempty)- grs' p s (`failsLeaving` "")-- describe "takeP" $ do- context "when taking 0 tokens" $ do- context "when stream is empty" $- it "succeeds returning zero-length chunk" $ do- let p :: MonadParsec Void String m => m String- p = takeP Nothing 0- grs p "" (`shouldParse` "")- context "when stream is not empty" $- it "succeeds returning zero-length chunk" $- property $ \s -> not (null s) ==> do- let p :: MonadParsec Void String m => m String- p = takeP Nothing 0- grs p s (`shouldParse` "")- grs' p s (`succeedsLeaving` s)- context "when taking >0 tokens" $ do- context "when stream is empty" $ do- context "with label" $- it "signals correct parse error" $- property $ \(Positive n) -> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- pe = err 0 (ueof <> elabel "foo")- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "without label" $- it "signals correct parse error" $- property $ \(Positive n) -> do- let p :: MonadParsec Void String m => m String- p = takeP Nothing n- pe = err 0 ueof- grs p "" (`shouldFailWith` pe)- context "when stream has not enough tokens" $- it "signals correct parse error" $- property $ \(Positive n) s -> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- m = length s- pe = err m (ueof <> elabel "foo")- unless (length s < n && not (null s)) discard- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` s)- context "when stream has enough tokens" $- it "succeeds returning the extracted tokens" $- property $ \(Positive n) s -> length s >= n ==> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- (s0,s1) = splitAt n s- grs p s (`shouldParse` s0)- grs' p s (`succeedsLeaving` s1)- context "when failing right after takeP (testing hints)" $- it "there are no hints to influence the parse error" $- property $ \(Positive n) s -> length s >= n ==> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n <* empty- pe = err n mempty- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` drop n s)-- describe "derivatives from primitive combinators" $ do-- -- NOTE 'single' is tested via 'char' in "Text.Megaparsec.Char" and- -- "Text.Megaparsec.Byte".-- describe "anySingle" $ do- let p :: MonadParsec Void String m => m Char- p = anySingle- context "when stream is not empty" $- it "succeeds consuming next character in the stream" $- property $ \ch s -> do- let s' = ch : s- grs p s' (`shouldParse` ch)- grs' p s' (`succeedsLeaving` s)- context "when stream is empty" $- it "signals correct parse error" $- grs p "" (`shouldFailWith` err 0 ueof)-- describe "anySingleBut" $ do- context "when stream begins with the character specified as argument" $- it "signals correct parse error" $- property $ \ch s' -> do- let p :: MonadParsec Void String m => m Char- p = anySingleBut ch- s = ch : s'- grs p s (`shouldFailWith` err 0 (utok ch))- grs' p s (`failsLeaving` s)- context "when stream does not begin with the character specified as argument" $- it "parses first character in the stream" $- property $ \ch s -> not (null s) && ch /= head s ==> do- let p :: MonadParsec Void String m => m Char- p = anySingleBut ch- grs p s (`shouldParse` head s)- grs' p s (`succeedsLeaving` tail s)- context "when stream is empty" $- it "signals correct parse error" $- grs (anySingleBut 'a') "" (`shouldFailWith` err 0 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)- s' = ch : s- grs (oneOf chs) s' (`shouldParse` ch)- grs' (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- grs (oneOf chs) s' (`shouldFailWith` err 0 (utok ch))- grs' (oneOf chs) s' (`failsLeaving` s')- context "when stream is empty" $- it "signals correct parse error" $- property $ \chs ->- grs (oneOf (chs :: String)) "" (`shouldFailWith` err 0 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- grs (noneOf chs) s' (`shouldParse` ch)- grs' (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- grs (noneOf chs) s' (`shouldFailWith` err 0 (utok ch))- grs' (noneOf chs) s' (`failsLeaving` s')- context "when stream is empty" $- it "signals correct parse error" $- property $ \chs ->- grs (noneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)-- -- NOTE 'chunk' is tested via 'string' in "Text.Megaparsec.Char" and- -- "Text.Megaparsec.Byte".-- describe "unexpected" $- it "signals correct parse error" $- property $ \item -> do- let p :: MonadParsec Void String m => m ()- p = void (unexpected item)- grs p "" (`shouldFailWith` TrivialError 0 (pure item) E.empty)-- describe "customFailure" $- it "signals correct parse error" $- property $ \n st -> do- let p :: MonadParsec Int String m => m ()- p = void (customFailure n)- xs = E.singleton (ErrorCustom n)- runParser p "" (stateInput st) `shouldFailWith` FancyError 0 xs- runParser' p st `failsLeaving` stateInput st-- 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' e o' -> do- let p :: Parsec Int String Int- p = region f $- case e :: ParseError String Int of- TrivialError _ us ps -> failure us ps- FancyError _ xs -> fancyFailure xs- f (TrivialError o us ps) = FancyError- (max o o')- (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)- f (FancyError o xs) = FancyError- (max o o')- (E.singleton . ErrorCustom $ E.size xs)- r = FancyError- (max (errorOffset e) o')- (E.singleton . ErrorCustom $- case e of- TrivialError _ us ps -> maybe 0 (const 1) us + E.size ps- FancyError _ xs -> E.size xs )- finalOffset = max (errorOffset e) o'- st = st' { stateOffset = errorOffset e }- runParser' p st `shouldBe`- ( st { stateOffset = finalOffset }- , Left (mkBundle st r)- )-- describe "takeRest" $- it "returns rest of the input" $- property $ \st@State {..} -> do- let p :: Parser String- p = takeRest- st' = st- { stateInput = []- , stateOffset = stateOffset + length stateInput- , statePosState = statePosState- }- runParser' p st `shouldBe` (st', Right stateInput)-- describe "atEnd" $ do- let p, p' :: Parser Bool- p = atEnd- p' = p <* empty- context "when stream is empty" $ do- it "returns True" $- prs p "" `shouldParse` True- it "does not produce hints" $- prs p' "" `shouldFailWith` err 0 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 0 mempty- prs' p' s `failsLeaving` s-- describe "combinators for manipulating parser state" $ do-- describe "setInput and getInput" $- it "sets input and gets it back" $- property $ \s -> do- let p = do- st0 <- getInput- guard (null st0)- setInput s- result <- string s- st1 <- getInput- guard (null st1)- return result- prs p "" `shouldParse` s-- describe "getSourcePos" $- it "sets position and gets it back" $- property $ \st -> do- let p :: Parser SourcePos- p = getSourcePos- (spos, _, pst') = reachOffset (stateOffset st) (statePosState st)- runParser' p st `shouldBe` (st { statePosState = pst' }, Right spos)-- describe "setOffset and getOffset" $- it "sets number of processed tokens and gets it back" $- property $ \o -> do- let p = setOffset o >> getOffset- prs p "" `shouldParse` o-- describe "setParserState and getParserState" $- it "sets parser state and gets it back" $- property $ \s1 s2 -> do- let p :: MonadParsec Void String m => m (State String)- p = do- st <- getParserState- guard (st == initialState s)- setParserState s1- updateParserState (f s2)- getParserState <* setInput ""- f (State s1' o pst) (State s2' _ _) = State (max s1' s2') o pst- s = ""- grs p s (`shouldParse` f s2 s1)-- describe "running a parser" $ do- describe "parseMaybe" $- it "returns result on success and Nothing on failure" $- property $ \s s' -> do- let p = string s' :: Parser String- parseMaybe p s `shouldBe`- if s == s' then Just s else Nothing-- describe "runParser'" $- it "works" $- property $ \st s -> do- let p = string s- runParser' p st `shouldBe` emulateStrParsing st s-- describe "runParserT'" $- it "works" $- property $ \st s -> do- let p = string s- runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s-- describe "MonadParsec instance of ReaderT" $ do-- describe "try" $- it "generally works" $- property $ \pre ch1 ch2 -> do- let s1 = pre : [ch1]- s2 = pre : [ch2]- getS1 = asks fst- getS2 = asks snd- p = try (g =<< getS1) <|> (g =<< getS2)- g = sequence . fmap char- s = [pre]- prs (runReaderT p (s1, s2)) s `shouldFailWith`- err 1 (ueof <> etok ch1 <> etok ch2)-- describe "notFollowedBy" $- it "generally works" $- property $ \a' b' c' -> do- let p = many (char =<< ask) <* notFollowedBy eof <* many anySingle- [a,b,c] = getNonNegative <$> [a',b',c']- s = abcRow a b c- if b > 0 || c > 0- then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'- else prs (runReaderT p 'a') s `shouldFailWith`- err a (ueof <> etok 'a')-- describe "MonadParsec instance of lazy StateT" $ do-- describe "(<|>)" $- it "generally works" $- property $ \n -> do- let p = L.put n >>- ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get- prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)-- describe "lookAhead" $- it "generally works" $- property $ \n -> do- let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get- prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)-- describe "notFollowedBy" $- it "generally works" $- property $ \n -> do- let p = do- L.put n- let notEof = notFollowedBy (L.modify (* 2) >> eof)- some (try (anySingle <* notEof)) <* char 'x'- prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)-- describe "observing" $ do- context "when inner parser succeeds" $- it "can affect state" $- property $ \m n -> do- let p = do- L.put m- observing (L.modify (+ n))- prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)- context "when inner parser fails" $- it "cannot affect state" $- property $ \m n -> do- let p = do- L.put m- observing (L.modify (+ n) <* empty)- prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)-- describe "MonadParsec instance of strict StateT" $ do-- describe "(<|>)" $- it "generally works" $- property $ \n -> do- let p = S.put n >>- ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get- prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)-- describe "lookAhead" $- it "generally works" $- property $ \n -> do- let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get- prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)-- describe "notFollowedBy" $- it "generally works" $- property $ \n -> do- let p = do- S.put n- let notEof = notFollowedBy (S.modify (* 2) >> eof)- some (try (anySingle <* notEof)) <* char 'x'- prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)-- describe "observing" $ do- context "when inner parser succeeds" $- it "can affect state" $- property $ \m n -> do- let p = do- S.put m- observing (L.modify (+ n))- prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)- context "when inner parser fails" $- it "cannot affect state" $- property $ \m n -> do- let p = do- S.put m- observing (L.modify (+ n) <* empty)- prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)-- describe "MonadParsec instance of lazy WriterT" $ do-- it "generally works" $- property $ \pre post -> do- let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x- loggedEof = eof >> L.tell "EOF"- p = do- L.tell pre- cs <- L.censor (fmap toUpper) $- some (try (loggedLetter <* notFollowedBy loggedEof))- L.tell post- void loggedLetter- return cs- prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")-- describe "lookAhead" $- it "discards what writer tells inside it" $- property $ \w -> do- let p = lookAhead (L.tell [w])- prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])-- describe "notFollowedBy" $- it "discards what writer tells inside it" $- property $ \w -> do- let p = notFollowedBy (L.tell [w] <* char 'a')- prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])-- describe "observing" $ do- context "when inner parser succeeds" $- it "can affect log" $- property $ \n -> do- let p = observing (L.tell $ Sum n)- prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)- context "when inner parser fails" $- it "cannot affect log" $- property $ \n -> do- let p = observing (L.tell (Sum n) <* empty)- prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)-- describe "MonadParsec instance of strict WriterT" $ do-- it "generally works" $- property $ \pre post -> do- let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x- loggedEof = eof >> S.tell "EOF"- p = do- S.tell pre- cs <- L.censor (fmap toUpper) $- some (try (loggedLetter <* notFollowedBy loggedEof))- S.tell post- void loggedLetter- return cs- prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")-- describe "lookAhead" $- it "discards what writer tells inside it" $- property $ \w -> do- let p = lookAhead (S.tell [w])- prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])-- describe "notFollowedBy" $- it "discards what writer tells inside it" $- property $ \w -> do- let p = notFollowedBy (S.tell [w] <* char 'a')- prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])-- describe "observing" $ do- context "when inner parser succeeds" $- it "can affect log" $- property $ \n -> do- let p = observing (S.tell $ Sum n)- prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)- context "when inner parser fails" $- it "cannot affect log" $- property $ \n -> do- let p = observing (S.tell (Sum n) <* empty)- prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)-- describe "MonadParsec instance of lazy RWST" $ do-- describe "label" $- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = label "a" ((,) <$> L.ask <*> L.get)- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "try" $- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = try ((,) <$> L.ask <*> L.get)- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "lookAhead" $ do- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = lookAhead ((,) <$> L.ask <*> L.get)- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])- it "discards what writer tells inside it" $- property $ \w -> do- let p = lookAhead (L.tell [w])- prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`- ((), 0, mempty :: [Int])- it "does not allow to influence state outside it" $- property $ \s0 s1 -> (s0 /= s1) ==> do- let p = lookAhead (L.put s1)- prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`- ((), s0, mempty :: [Int])-- describe "notFollowedBy" $ do- it "discards what writer tells inside it" $- property $ \w -> do- let p = notFollowedBy (L.tell [w] <* char 'a')- prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`- ((), 0, mempty :: [Int])- it "does not allow to influence state outside it" $- property $ \s0 s1 -> (s0 /= s1) ==> do- let p = notFollowedBy (L.put s1 <* char 'a')- prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`- ((), s0, mempty :: [Int])-- describe "withRecovery" $ do- it "allows main parser to access reader context and state inside it" $- property $ \r s -> do- let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])- it "allows recovering parser to access reader context and state inside it" $- property $ \r s -> do- let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "observing" $ do- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = observing ((,) <$> L.ask <*> L.get)- prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- (Right (r, s), s, mempty :: [Int])- context "when the inner parser fails" $- it "backtracks state" $- property $ \r s0 s1 -> (s0 /= s1) ==> do- let p = observing (L.put s1 <* empty)- prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`- (Left (err 0 mempty), s0, mempty :: [Int])-- describe "MonadParsec instance of strict RWST" $ do-- describe "label" $- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = label "a" ((,) <$> S.ask <*> S.get)- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "try" $- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = try ((,) <$> S.ask <*> S.get)- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "lookAhead" $ do- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = lookAhead ((,) <$> S.ask <*> S.get)- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])- it "discards what writer tells inside it" $- property $ \w -> do- let p = lookAhead (S.tell [w])- prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`- ((), 0, mempty :: [Int])- it "does not allow to influence state outside it" $- property $ \s0 s1 -> (s0 /= s1) ==> do- let p = lookAhead (S.put s1)- prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`- ((), s0, mempty :: [Int])-- describe "notFollowedBy" $ do- it "discards what writer tells inside it" $- property $ \w -> do- let p = notFollowedBy (S.tell [w] <* char 'a')- prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`- ((), 0, mempty :: [Int])- it "does not allow to influence state outside it" $- property $ \s0 s1 -> (s0 /= s1) ==> do- let p = notFollowedBy (S.put s1 <* char 'a')- prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`- ((), s0, mempty :: [Int])-- describe "withRecovery" $ do- it "allows main parser to access reader context and state inside it" $- property $ \r s -> do- let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])- it "allows recovering parser to access reader context and state inside it" $- property $ \r s -> do- let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- ((r, s), s, mempty :: [Int])-- describe "observing" $ do- it "allows to access reader context and state inside it" $- property $ \r s -> do- let p = observing ((,) <$> S.ask <*> S.get)- prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`- (Right (r, s), s, mempty :: [Int])- context "when the inner parser fails" $- it "backtracks state" $- property $ \r s0 s1 -> (s0 /= s1) ==> do- let p = observing (S.put s1 <* empty)- prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`- (Left (err 0 mempty), s0, mempty :: [Int])--------------------------------------------------------------------------------- Helpers--instance ShowErrorComponent Int where- showErrorComponent = show--emulateStrParsing- :: State String- -> String- -> (State String, Either (ParseErrorBundle String Void) String)-emulateStrParsing st@(State i o pst) s =- if s == take l i- then ( State (drop l i) (o + l) pst- , Right s )- else ( st- , Left (mkBundle st (err o (etoks s <> utoks (take l i))))- )- where- l = length s--eqParser :: (Eq a, Eq (Token s), Eq s)- => Parsec Void s a- -> Parsec Void s a- -> s- -> Bool-eqParser p1 p2 s = runParser p1 "" s == runParser p2 "" s--mkBundle :: State s -> ParseError s e -> ParseErrorBundle s e-mkBundle s e = ParseErrorBundle- { bundleErrors = e :| []- , bundlePosState = statePosState s- }--grabTabWidth :: (State a, b) -> Pos-grabTabWidth = pstateTabWidth . statePosState . fst