diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/LICENSE.md b/LICENSE.md
--- a/LICENSE.md
+++ b/LICENSE.md
@@ -1,5 +1,5 @@
-Copyright © 2015–2018 Megaparsec contributors
-Copyright © 2007 Paolo Martini
+Copyright © 2015–2019 Megaparsec contributors\
+Copyright © 2007 Paolo Martini\
Copyright © 1999–2000 Daan Leijen
All rights reserved.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -334,7 +334,7 @@
## License
-Copyright © 2015–2018 Megaparsec contributors\
+Copyright © 2015–2019 Megaparsec contributors\
Copyright © 2007 Paolo Martini\
Copyright © 1999–2000 Daan Leijen
diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs
--- a/Text/Megaparsec.hs
+++ b/Text/Megaparsec.hs
@@ -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
diff --git a/Text/Megaparsec/Byte.hs b/Text/Megaparsec/Byte.hs
--- a/Text/Megaparsec/Byte.hs
+++ b/Text/Megaparsec/Byte.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Byte
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Byte/Lexer.hs b/Text/Megaparsec/Byte/Lexer.hs
--- a/Text/Megaparsec/Byte/Lexer.hs
+++ b/Text/Megaparsec/Byte/Lexer.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Byte.Lexer
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs
--- a/Text/Megaparsec/Char.hs
+++ b/Text/Megaparsec/Char.hs
@@ -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
diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs
--- a/Text/Megaparsec/Char/Lexer.hs
+++ b/Text/Megaparsec/Char/Lexer.hs
@@ -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
diff --git a/Text/Megaparsec/Class.hs b/Text/Megaparsec/Class.hs
--- a/Text/Megaparsec/Class.hs
+++ b/Text/Megaparsec/Class.hs
@@ -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
diff --git a/Text/Megaparsec/Common.hs b/Text/Megaparsec/Common.hs
--- a/Text/Megaparsec/Common.hs
+++ b/Text/Megaparsec/Common.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Common
--- Copyright : © 2018 Megaparsec contributors
+-- Copyright : © 2018–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Debug.hs b/Text/Megaparsec/Debug.hs
--- a/Text/Megaparsec/Debug.hs
+++ b/Text/Megaparsec/Debug.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Debug
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs
--- a/Text/Megaparsec/Error.hs
+++ b/Text/Megaparsec/Error.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Error
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Error/Builder.hs b/Text/Megaparsec/Error/Builder.hs
--- a/Text/Megaparsec/Error/Builder.hs
+++ b/Text/Megaparsec/Error/Builder.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Error.Builder
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Internal.hs b/Text/Megaparsec/Internal.hs
--- a/Text/Megaparsec/Internal.hs
+++ b/Text/Megaparsec/Internal.hs
@@ -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
diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs
--- a/Text/Megaparsec/Lexer.hs
+++ b/Text/Megaparsec/Lexer.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Common
--- Copyright : © 2018 Megaparsec contributors
+-- Copyright : © 2018–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs
--- a/Text/Megaparsec/Pos.hs
+++ b/Text/Megaparsec/Pos.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Pos
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
diff --git a/Text/Megaparsec/State.hs b/Text/Megaparsec/State.hs
--- a/Text/Megaparsec/State.hs
+++ b/Text/Megaparsec/State.hs
@@ -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
diff --git a/Text/Megaparsec/Stream.hs b/Text/Megaparsec/Stream.hs
--- a/Text/Megaparsec/Stream.hs
+++ b/Text/Megaparsec/Stream.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Text.Megaparsec.Stream
--- Copyright : © 2015–2018 Megaparsec contributors
+-- Copyright : © 2015–2019 Megaparsec contributors
-- License : FreeBSD
--
-- Maintainer : Mark Karpov
@@ -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.
diff --git a/megaparsec.cabal b/megaparsec.cabal
--- a/megaparsec.cabal
+++ b/megaparsec.cabal
@@ -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
diff --git a/tests/Control/Applicative/CombinatorsSpec.hs b/tests/Control/Applicative/CombinatorsSpec.hs
deleted file mode 100644
--- a/tests/Control/Applicative/CombinatorsSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Control/Applicative/PermutationsSpec.hs b/tests/Control/Applicative/PermutationsSpec.hs
deleted file mode 100644
--- a/tests/Control/Applicative/PermutationsSpec.hs
+++ /dev/null
@@ -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]
diff --git a/tests/Control/Monad/Combinators/ExprSpec.hs b/tests/Control/Monad/Combinators/ExprSpec.hs
deleted file mode 100644
--- a/tests/Control/Monad/Combinators/ExprSpec.hs
+++ /dev/null
@@ -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 "-")] ]
diff --git a/tests/Control/Monad/CombinatorsSpec.hs b/tests/Control/Monad/CombinatorsSpec.hs
deleted file mode 100644
--- a/tests/Control/Monad/CombinatorsSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Main.hs b/tests/Main.hs
deleted file mode 100644
--- a/tests/Main.hs
+++ /dev/null
@@ -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
diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs
deleted file mode 100644
--- a/tests/Test/Hspec/Megaparsec.hs
+++ /dev/null
@@ -1,302 +0,0 @@
--- |
--- Module : Test.Hspec.Megaparsec
--- Copyright : © 2016–2018 Mark Karpov
--- License : BSD 3 clause
---
--- Maintainer : Mark Karpov
--- 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
diff --git a/tests/Test/Hspec/Megaparsec/AdHoc.hs b/tests/Test/Hspec/Megaparsec/AdHoc.hs
deleted file mode 100644
--- a/tests/Test/Hspec/Megaparsec/AdHoc.hs
+++ /dev/null
@@ -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
diff --git a/tests/Text/Megaparsec/Byte/LexerSpec.hs b/tests/Text/Megaparsec/Byte/LexerSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/Byte/LexerSpec.hs
+++ /dev/null
@@ -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)
diff --git a/tests/Text/Megaparsec/ByteSpec.hs b/tests/Text/Megaparsec/ByteSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/ByteSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Text/Megaparsec/Char/LexerSpec.hs b/tests/Text/Megaparsec/Char/LexerSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/Char/LexerSpec.hs
+++ /dev/null
@@ -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)
diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/CharSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Text/Megaparsec/DebugSpec.hs b/tests/Text/Megaparsec/DebugSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/DebugSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/ErrorSpec.hs
+++ /dev/null
@@ -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 | \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 | \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 = ""
- }
- }
diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/PosSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Text/Megaparsec/StreamSpec.hs b/tests/Text/Megaparsec/StreamSpec.hs
deleted file mode 100644
--- a/tests/Text/Megaparsec/StreamSpec.hs
+++ /dev/null
@@ -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" "\"{\"")
-
--- | 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 " $
- property $ \o pst' -> do
- let pst = (pst' :: PosState s)
- { pstateInput = "" :: s
- , pstateLinePrefix = ""
- }
- (_, r, _) = reachOffset o pst
- r `shouldBe` ""
- 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)
diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs
deleted file mode 100644
--- a/tests/Text/MegaparsecSpec.hs
+++ /dev/null
@@ -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