Merge pull request #138 from mrkkrp/migrate-to-hspec

Re-write the tests with Hspec and more

.travis.yml

@@ -33,10 +33,11 @@ script:
     "1.18") cabal configure --enable-tests --enable-library-coverage -v2 -f dev ;;
     *)      cabal configure --enable-tests --enable-coverage -v2 -f dev ;;
    esac
- - travis_wait 40 cabal build
+ - travis_wait 60 cabal build
- - cabal test --show-details=always
+ - case "$GHCVER" in
-              --test-option=--threads=2
+    "7.6.3") true ;;
-              --test-option=--maximum-generated-tests=1000
+    *)       cabal test --show-details=always --test-option=--qc-max-success=1000 ;;
+   esac
  - cabal sdist
  - if [ "$CABALVER" != "1.16" ]; then
     cabal haddock | grep "100%" | wc -l | grep "14";

CHANGELOG.md

@@ -9,6 +9,20 @@
 * Exposed `parseErrorTextPretty` function in `Text.Megaparsec.Error` to
   allow render `ParseError`s without stack of source positions.
 
+* Eliminated the `old-tests` test suite — Parsec legacy. The cases that are
+  not already *obviously* covered in the main test suite were included into
+  it.
+
+* Added `Arbitrary` instances for the following data types: `Pos`,
+  `SourcePos`, `ErrorItem`, `Dec`, `ParseError` and `State`. This should
+  make testing easier without the need to add orphan instances every time.
+  The drawback is that we start to depend on `QuickCheck`, but that's a fair
+  price.
+
+* The test suite now uses the combination of Hspec and the
+  `hpesc-megaparsec` package, which also improved the latter (that package
+  is the recommended way to test Megaparsec parsers).
+
 ## Megaparsec 5.0.1
 
 * Derived `NFData` instances for `Pos`, `InvalidPosException`, `SourcePos`,

Text/Megaparsec/Char.hs

@@ -402,7 +402,7 @@ string' = tokens casei
 -- | Case-insensitive equality test for characters.
 
 casei :: Char -> Char -> Bool
-casei x y = toLower x == toLower y
+casei x y = toUpper x == toUpper y
 {-# INLINE casei #-}
 
 -- | Case-insensitive 'elem'.

Text/Megaparsec/Error.hs

@@ -41,13 +41,14 @@ import Data.Set (Set)
 import Data.Typeable (Typeable)
 import GHC.Generics
 import Prelude hiding (concat)
+import Test.QuickCheck hiding (label)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set           as E
 
 import Text.Megaparsec.Pos
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+import Control.Applicative
 #endif
 
 -- | Data type that is used to represent “unexpected\/expected” items in
@@ -63,6 +64,18 @@ data ErrorItem t
 
 instance NFData t => NFData (ErrorItem t)
 
+instance Arbitrary t => Arbitrary (ErrorItem t) where
+  arbitrary = oneof
+    [
+#if !MIN_VERSION_QuickCheck(2,9,0)
+      Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)
+    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)
+#else
+      Tokens <$> arbitrary
+    , Label  <$> arbitrary
+#endif
+    , return EndOfInput ]
+
 -- | The type class defines how to represent information about various
 -- exceptional situations. Data types that are used as custom data component
 -- in 'ParseError' must be instances of this type class.
@@ -104,6 +117,13 @@ instance NFData Dec where
   rnf (DecFail str) = rnf str
   rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act
 
+instance Arbitrary Dec where
+  arbitrary = oneof
+    [ sized (\n -> do
+        k <- choose (0, n `div` 2)
+        DecFail <$> vectorOf k arbitrary)
+    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]
+
 instance ErrorComponent Dec where
   representFail        = DecFail
   representIndentation = DecIndentation
@@ -152,6 +172,19 @@ instance ( Show t
   displayException = parseErrorPretty
 #endif
 
+instance (Arbitrary t, Ord t, Arbitrary e, Ord e)
+    => Arbitrary (ParseError t e) where
+  arbitrary = ParseError
+    <$>
+#if !MIN_VERSION_QuickCheck(2,9,0)
+      (NE.fromList . getNonEmpty <$> arbitrary)
+#else
+      arbitrary
+#endif
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+
 -- | Merge two error data structures into one joining their collections of
 -- message items and preferring longest match. In other words, earlier error
 -- message is discarded. This may seem counter-intuitive, but 'mergeError'
@@ -197,15 +230,41 @@ stringPretty xs           = "\"" ++ NE.toList xs ++ "\""
 -- character @ch@, suitable for using in error messages.
 
 charPretty :: Char -> String
-charPretty '\0' = "null"
+charPretty '\NUL' = "null (control character)"
-charPretty '\a' = "bell"
+charPretty '\SOH' = "start of heading (control character)"
-charPretty '\b' = "backspace"
+charPretty '\STX' = "start of text (control character)"
-charPretty '\t' = "tab"
+charPretty '\ETX' = "end of text (control character)"
-charPretty '\n' = "newline"
+charPretty '\EOT' = "end of transmission (control character)"
-charPretty '\v' = "vertical tab"
+charPretty '\ENQ' = "enquiry (control character)"
-charPretty '\f' = "form feed"
+charPretty '\ACK' = "acknowledge (control character)"
-charPretty '\r' = "carriage return"
+charPretty '\BEL' = "bell (control character)"
-charPretty ' '  = "space"
+charPretty '\BS'  = "backspace"
+charPretty '\t'   = "tab"
+charPretty '\n'   = "newline"
+charPretty '\v'   = "vertical tab"
+charPretty '\f'   = "form feed (control character)"
+charPretty '\r'   = "carriage return"
+charPretty '\SO'  = "shift out (control character)"
+charPretty '\SI'  = "shift in (control character)"
+charPretty '\DLE' = "data link escape (control character)"
+charPretty '\DC1' = "device control one (control character)"
+charPretty '\DC2' = "device control two (control character)"
+charPretty '\DC3' = "device control three (control character)"
+charPretty '\DC4' = "device control four (control character)"
+charPretty '\NAK' = "negative acknowledge (control character)"
+charPretty '\SYN' = "synchronous idle (control character)"
+charPretty '\ETB' = "end of transmission block (control character)"
+charPretty '\CAN' = "cancel (control character)"
+charPretty '\EM'  = "end of medium (control character)"
+charPretty '\SUB' = "substitute (control character)"
+charPretty '\ESC' = "escape (control character)"
+charPretty '\FS'  = "file separator (control character)"
+charPretty '\GS'  = "group separator (control character)"
+charPretty '\RS'  = "record separator (control character)"
+charPretty '\US'  = "unit separator (control character)"
+charPretty '\DEL' = "delete (control character)"
+charPretty ' '    = "space"
+charPretty '\160' = "non-breaking space"
 charPretty x    = "'" ++ [x] ++ "'"
 
 -- | The type class defines how to print custom data component of

Text/Megaparsec/Pos.hs

@@ -39,10 +39,11 @@ import Data.Data (Data)
 import Data.Semigroup
 import Data.Typeable (Typeable)
 import GHC.Generics
+import Test.QuickCheck
 import Unsafe.Coerce
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+import Control.Applicative
 import Data.Word (Word)
 #endif
 
@@ -58,6 +59,9 @@ import Data.Word (Word)
 newtype Pos = Pos Word
   deriving (Show, Eq, Ord, Data, Typeable, NFData)
 
+instance Arbitrary Pos where
+  arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))
+
 -- | Construction of 'Pos' from an instance of 'Integral'. The function
 -- throws 'InvalidPosException' when given non-positive argument. Note that
 -- the function is polymorphic with respect to 'MonadThrow' @m@, so you can
@@ -103,6 +107,14 @@ instance Read Pos where
       (x,     r3) <- readsPrec 11 r2
       (,r3) <$> mkPos (x :: Integer)
 
+instance Arbitrary SourcePos where
+  arbitrary = SourcePos
+    <$> sized (\n -> do
+          k <- choose (0, n `div` 2)
+          vectorOf k arbitrary)
+    <*> (unsafePos <$> choose (1, 1000))
+    <*> (unsafePos <$> choose (1,  100))
+
 -- | The exception is thrown by 'mkPos' when its argument is not a positive
 -- number.
 --

Text/Megaparsec/Prim.hs

@@ -76,6 +76,7 @@ import Data.Set (Set)
 import Data.Typeable (Typeable)
 import GHC.Generics
 import Prelude hiding (all)
+import Test.QuickCheck hiding (Result (..), label)
 import qualified Control.Applicative               as A
 import qualified Control.Monad.Fail                as Fail
 import qualified Control.Monad.Trans.Reader        as L
@@ -94,7 +95,7 @@ import Text.Megaparsec.Error
 import Text.Megaparsec.Pos
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*), pure)
+import Control.Applicative
 #endif
 
 ----------------------------------------------------------------------------
@@ -110,6 +111,17 @@ data State s = State
 
 instance NFData s => NFData (State s)
 
+instance Arbitrary a => Arbitrary (State a) where
+  arbitrary = State
+    <$> arbitrary
+    <*>
+#if !MIN_VERSION_QuickCheck(2,9,0)
+      (NE.fromList . getNonEmpty <$> arbitrary)
+#else
+      arbitrary
+#endif
+    <*> (unsafePos <$> choose (1, 20))
+
 -- | All information available after parsing. This includes consumption of
 -- input, success (with returned value) or failure (with parse error), and
 -- parser state at the end of parsing.

megaparsec.cabal

@@ -56,7 +56,8 @@ flag dev
   default:            False
 
 library
-  build-depends:      base         >= 4.6   && < 5.0
+  build-depends:      QuickCheck   >= 2.7   && < 3.0
+                    , base         >= 4.6   && < 5.0
                     , bytestring   >= 0.2   && < 0.11
                     , containers   >= 0.5   && < 0.6
                     , deepseq      >= 1.3   && < 1.5
@@ -98,59 +99,36 @@ library
     ghc-options:      -O2 -Wall
   default-language:   Haskell2010
 
-test-suite old-tests
-  main-is:            Main.hs
-  hs-source-dirs:     old-tests
-  type:               exitcode-stdio-1.0
-  if flag(dev)
-    ghc-options:      -Wall -Werror
-  else
-    ghc-options:      -O2 -Wall
-  other-modules:      Bugs
-                    , Bugs.Bug2
-                    , Bugs.Bug6
-                    , Bugs.Bug9
-                    , Bugs.Bug35
-                    , Bugs.Bug39
-                    , Util
-  build-depends:      base                 >= 4.6 && < 5.0
-                    , HUnit                >= 1.2 && < 1.4
-                    , megaparsec           >= 5.0.1
-                    , test-framework       >= 0.6 && < 1.0
-                    , test-framework-hunit >= 0.2 && < 0.4
-  default-language:   Haskell2010
-
 test-suite tests
-  main-is:            Main.hs
+  main-is:            Spec.hs
   hs-source-dirs:     tests
   type:               exitcode-stdio-1.0
   if flag(dev)
     ghc-options:      -Wall -Werror
   else
     ghc-options:      -O2 -Wall
-  other-modules:      Char
+  other-modules:      Test.Hspec.Megaparsec
-                    , Combinator
+                    , Test.Hspec.Megaparsec.AdHoc
-                    , Error
+                    , Text.Megaparsec.CharSpec
-                    , Expr
+                    , Text.Megaparsec.CombinatorSpec
-                    , Lexer
+                    , Text.Megaparsec.ErrorSpec
-                    , Perm
+                    , Text.Megaparsec.ExprSpec
-                    , Pos
+                    , Text.Megaparsec.LexerSpec
-                    , Prim
+                    , Text.Megaparsec.PermSpec
-                    , Util
+                    , Text.Megaparsec.PosSpec
-  build-depends:      base           >= 4.6   && < 5.0
+                    , Text.Megaparsec.PrimSpec
-                    , HUnit          >= 1.2   && < 1.4
+  build-depends:      QuickCheck   >= 2.7   && < 3.0
-                    , QuickCheck     >= 2.8.2 && < 3.0
+                    , base         >= 4.6   && < 5.0
-                    , bytestring     >= 0.2   && < 0.11
+                    , bytestring   >= 0.2   && < 0.11
-                    , containers     >= 0.5   && < 0.6
+                    , containers   >= 0.5   && < 0.6
-                    , exceptions     >= 0.6   && < 0.9
+                    , exceptions   >= 0.6   && < 0.9
-                    , megaparsec     >= 5.0.1
+                    , hspec        >= 2.0   && < 3.0
-                    , mtl            >= 2.0   && < 3.0
+                    , hspec-expectations >= 0.5 && < 0.8
-                    , scientific     >= 0.3.1 && < 0.4
+                    , megaparsec   >= 5.0.1
-                    , test-framework >= 0.6   && < 1.0
+                    , mtl          >= 2.0   && < 3.0
-                    , test-framework-hunit       >= 0.3 && < 0.4
+                    , scientific   >= 0.3.1 && < 0.4
-                    , test-framework-quickcheck2 >= 0.3 && < 0.4
+                    , text         >= 0.2   && < 1.3
-                    , text           >= 0.2   && < 1.3
+                    , transformers >= 0.4   && < 0.6
-                    , transformers   >= 0.4   && < 0.6
 
   if !impl(ghc >= 8.0)
     -- packages providing modules that moved into base-4.9.0.0
@@ -169,11 +147,11 @@ benchmark benchmarks
     ghc-options:      -O2 -Wall -Werror
   else
     ghc-options:      -O2 -Wall
-  build-depends:      base       >= 4.6  && < 5.0
+  build-depends:      base         >= 4.6  && < 5.0
-                    , bytestring >= 0.10 && < 0.11
+                    , bytestring   >= 0.10 && < 0.11
-                    , criterion  >= 0.6.2.1 && < 1.2
+                    , criterion    >= 0.6.2.1 && < 1.2
-                    , megaparsec >= 5.0.1
+                    , megaparsec   >= 5.0.1
-                    , text       >= 0.2  && < 1.3
+                    , text         >= 0.2  && < 1.3
   default-language:   Haskell2010
 
 source-repository head

megaparsec.ebal

@@ -1 +1 @@
-((test "--test-arguments=--threads=2 --maximum-generated-tests=1000"))
+((test "--test-arguments=--qc-max-success=1000"))

old-tests/Bugs.hs

@@ -1,16 +0,0 @@
-module Bugs (bugs) where
-
-import Test.Framework
-
-import qualified Bugs.Bug2
-import qualified Bugs.Bug6
-import qualified Bugs.Bug9
-import qualified Bugs.Bug35
-import qualified Bugs.Bug39
-
-bugs :: [Test]
-bugs = [ Bugs.Bug2.main
-       , Bugs.Bug6.main
-       , Bugs.Bug9.main
-       , Bugs.Bug35.main
-       , Bugs.Bug39.main ]

old-tests/Bugs/Bug2.hs

@@ -1,32 +0,0 @@
-module Bugs.Bug2 (main) where
-
-import Control.Applicative (empty)
-import Control.Monad (void)
-
-import Text.Megaparsec
-import Text.Megaparsec.String
-import qualified Text.Megaparsec.Lexer as L
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-sc :: Parser ()
-sc = L.space (void spaceChar) empty empty
-
-lexeme :: Parser a -> Parser a
-lexeme = L.lexeme sc
-
-stringLiteral :: Parser String
-stringLiteral = lexeme $ char '"' >> manyTill L.charLiteral (char '"')
-
-main :: Test
-main =
-  testCase "Control Char Parsing (#2)" $
-  parseString "\"test\\^Bstring\"" @?= "test\^Bstring"
- where
-   parseString :: String -> String
-   parseString input =
-      case parse stringLiteral "Example" input of
-        Left{} -> error "Parse failure"
-        Right str -> str

old-tests/Bugs/Bug35.hs

@@ -1,35 +0,0 @@
-module Bugs.Bug35 (main) where
-
-import Text.Megaparsec
-import Text.Megaparsec.String
-import qualified Text.Megaparsec.Lexer as L
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-trickyFloats :: [String]
-trickyFloats =
-    [ "1.5339794352098402e-118"
-    , "2.108934760892056e-59"
-    , "2.250634744599241e-19"
-    , "5.0e-324"
-    , "5.960464477539063e-8"
-    , "0.25996181067141905"
-    , "0.3572019862807257"
-    , "0.46817723004874223"
-    , "0.9640035681058178"
-    , "4.23808622486133"
-    , "4.540362294799751"
-    , "5.212384849884261"
-    , "13.958257048123212"
-    , "32.96176575630599"
-    , "38.47735512322269" ]
-
-testBatch :: Assertion
-testBatch = mapM_ testFloat trickyFloats
-  where testFloat x = parse (L.float :: Parser Double) "" x
-          @?= Right (read x :: Double)
-
-main :: Test
-main = testCase "Output of Text.Megaparsec.Lexer.float (#35)" testBatch

old-tests/Bugs/Bug39.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Bugs.Bug39 (main) where
-
-import Control.Applicative (empty)
-import Control.Monad (void)
-#if MIN_VERSION_base(4,7,0)
-import Data.Either (isLeft, isRight)
-#endif
-
-import Text.Megaparsec
-import Text.Megaparsec.String
-import qualified Text.Megaparsec.Lexer as L
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-#if !MIN_VERSION_base(4,7,0)
-isRight, isLeft :: Either a b -> Bool
-isRight (Right _) = True
-isRight _         = False
-isLeft  (Left _ ) = True
-isLeft  _         = False
-#endif
-
-shouldFail :: [String]
-shouldFail = [" 1", " +1", " -1"]
-
-shouldSucceed :: [String]
-shouldSucceed = ["1", "+1", "-1", "+ 1 ", "- 1 ", "1 "]
-
-sc :: Parser ()
-sc = L.space (void spaceChar) empty empty
-
-lexeme :: Parser a -> Parser a
-lexeme = L.lexeme sc
-
-integer :: Parser Integer
-integer = lexeme $ L.signed sc L.integer
-
-testBatch :: Assertion
-testBatch = mapM_ (f testFail)    shouldFail >>
-            mapM_ (f testSucceed) shouldSucceed
-    where f           t a = t (parse integer "" a) a
-          testFail    x a = assertBool
-                            ("Should fail on " ++ show a) (isLeft x)
-          testSucceed x a = assertBool
-                            ("Should succeed on " ++ show a) (isRight x)
-
-main :: Test
-main = testCase "Lexer should fail on leading whitespace (#39)" testBatch

old-tests/Bugs/Bug6.hs

@@ -1,22 +0,0 @@
-module Bugs.Bug6 (main) where
-
-import Text.Megaparsec
-import Text.Megaparsec.String
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-import Util
-
-main :: Test
-main =
-  testCase "Look-ahead preserving error location (#6)" $
-  parseErrors variable "return" @?= ["'return' is a reserved keyword"]
-
-variable :: Parser String
-variable = do
-  x <- lookAhead (some letterChar)
-  if x == "return"
-    then fail "'return' is a reserved keyword"
-    else string x

old-tests/Bugs/Bug9.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Bugs.Bug9 (main) where
-
-import Control.Applicative (empty)
-import Control.Monad (void)
-
-import Text.Megaparsec
-import Text.Megaparsec.Expr
-import Text.Megaparsec.String (Parser)
-import qualified Text.Megaparsec.Lexer as L
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-import Util
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*), (<$))
-#endif
-
-data Expr = Const Integer | Op Expr Expr deriving Show
-
-main :: Test
-main =
-  testCase "Tracing of current position in error message (#9)"
-  $ result @?= ["unexpected '>'", "expecting end of input or operator"]
-  where
-    result :: [String]
-    result = parseErrors parseTopLevel "4 >> 5"
-
--- Syntax analysis
-
-sc :: Parser ()
-sc = L.space (void spaceChar) empty empty
-
-lexeme :: Parser a -> Parser a
-lexeme = L.lexeme sc
-
-integer :: Parser Integer
-integer = lexeme L.integer
-
-operator :: String -> Parser String
-operator = L.symbol sc
-
-parseTopLevel :: Parser Expr
-parseTopLevel = parseExpr <* eof
-
-parseExpr :: Parser Expr
-parseExpr = makeExprParser (Const <$> integer) table
-  where table = [[ InfixL (Op <$ operator ">>>") ]]

old-tests/Main.hs

@@ -1,6 +0,0 @@
-import Test.Framework
-
-import Bugs (bugs)
-
-main :: IO ()
-main = defaultMain [testGroup "Bugs" bugs]

old-tests/Util.hs

@@ -1,12 +0,0 @@
-module Util where
-
-import Text.Megaparsec
-import Text.Megaparsec.String (Parser)
-
--- | Returns the error messages associated with a failed parse.
-
-parseErrors :: Parser a -> String -> [String]
-parseErrors p input =
-  case parse p "" input of
-    Left err -> drop 1 $ lines $ parseErrorPretty err
-    Right _  -> []

stack.yaml

@@ -1,3 +1,3 @@
-resolver: lts-6.11
+resolver: lts-6.15
 packages:
 - '.'

tests/Char.hs

@@ -1,246 +0,0 @@
---
--- QuickCheck tests for Megaparsec's character parsers.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-{-# LANGUAGE CPP              #-}
-{-# OPTIONS -fno-warn-orphans #-}
-
-module Char (tests) where
-
-import Data.Char
-import Data.List (findIndex, isPrefixOf)
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck
-
-import Text.Megaparsec.Char
-import Text.Megaparsec.Error
-
-import Util
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-#endif
-
-tests :: Test
-tests = testGroup "Character parsers"
-  [ testProperty "newline"         prop_newline
-  , testProperty "crlf"            prop_crlf
-  , testProperty "eol"             prop_eol
-  , testProperty "tab"             prop_tab
-  , testProperty "space"           prop_space
-  , testProperty "controlChar"     prop_controlChar
-  , testProperty "spaceChar"       prop_spaceChar
-  , testProperty "upperChar"       prop_upperChar
-  , testProperty "lowerChar"       prop_lowerChar
-  , testProperty "letterChar"      prop_letterChar
-  , testProperty "alphaNumChar"    prop_alphaNumChar
-  , testProperty "printChar"       prop_printChar
-  , testProperty "digitChar"       prop_digitChar
-  , testProperty "hexDigitChar"    prop_hexDigitChar
-  , testProperty "octDigitChar"    prop_octDigitChar
-  , testProperty "markChar"        prop_markChar
-  , testProperty "numberChar"      prop_numberChar
-  , testProperty "punctuationChar" prop_punctuationChar
-  , testProperty "symbolChar"      prop_symbolChar
-  , testProperty "separatorChar"   prop_separatorChar
-  , testProperty "asciiChar"       prop_asciiChar
-  , testProperty "latin1Char"      prop_latin1Char
-  , testProperty "charCategory"    prop_charCategory
-  , testProperty "char"            prop_char
-  , testProperty "char'"           prop_char'
-  , testProperty "anyChar"         prop_anyChar
-  , testProperty "oneOf"           prop_oneOf
-  , testProperty "oneOf'"          prop_oneOf'
-  , testProperty "noneOf"          prop_noneOf
-  , testProperty "noneOf'"         prop_noneOf'
-  , testProperty "string"          prop_string
-  , testProperty "string'"         prop_string'_0
-  , testProperty "string' (case)"  prop_string'_1 ]
-
-instance Arbitrary GeneralCategory where
-  arbitrary = elements [minBound..maxBound]
-
-prop_newline :: String -> Property
-prop_newline = checkChar newline (== '\n') (tkn '\n')
-
-prop_crlf :: String -> Property
-prop_crlf = checkString crlf "\r\n" (==)
-
-prop_eol :: String -> Property
-prop_eol s = checkParser eol r s
-  where h = head s
-        r | s == "\n"   = Right "\n"
-          | s == "\r\n" = Right "\r\n"
-          | null s      = posErr 0 s [ueof, elabel "end of line"]
-          | h == '\n'   = posErr 1 s [utok (s !! 1), eeof]
-          | h /= '\r'   = posErr 0 s [utok h, elabel "end of line"]
-          | "\r\n" `isPrefixOf` s = posErr 2 s [utok (s !! 2), eeof]
-          | otherwise   = posErr 0 s [ utoks (take 2 s)
-                                     , utok '\r'
-                                     , elabel "end of line" ]
-
-prop_tab :: String -> Property
-prop_tab = checkChar tab (== '\t') (tkn '\t')
-
-prop_space :: String -> Property
-prop_space s = checkParser space r s
-  where r = case findIndex (not . isSpace) s of
-              Just x  ->
-                  let ch = s !! x
-                  in posErr x s
-                     [ utok ch
-                     , utok ch
-                     , elabel "white space"
-                     , eeof ]
-              Nothing -> Right ()
-
-prop_controlChar :: String -> Property
-prop_controlChar = checkChar controlChar isControl (lbl "control character")
-
-prop_spaceChar :: String -> Property
-prop_spaceChar = checkChar spaceChar isSpace (lbl "white space")
-
-prop_upperChar :: String -> Property
-prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter")
-
-prop_lowerChar :: String -> Property
-prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter")
-
-prop_letterChar :: String -> Property
-prop_letterChar = checkChar letterChar isAlpha (lbl "letter")
-
-prop_alphaNumChar :: String -> Property
-prop_alphaNumChar = checkChar alphaNumChar isAlphaNum
-  (lbl "alphanumeric character")
-
-prop_printChar :: String -> Property
-prop_printChar = checkChar printChar isPrint (lbl "printable character")
-
-prop_digitChar :: String -> Property
-prop_digitChar = checkChar digitChar isDigit (lbl "digit")
-
-prop_octDigitChar :: String -> Property
-prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit")
-
-prop_hexDigitChar :: String -> Property
-prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit")
-
-prop_markChar :: String -> Property
-prop_markChar = checkChar markChar isMark (lbl "mark character")
-
-prop_numberChar :: String -> Property
-prop_numberChar = checkChar numberChar isNumber (lbl "numeric character")
-
-prop_punctuationChar :: String -> Property
-prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation")
-
-prop_symbolChar :: String -> Property
-prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol")
-
-prop_separatorChar :: String -> Property
-prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator")
-
-prop_asciiChar :: String -> Property
-prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character")
-
-prop_latin1Char :: String -> Property
-prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character")
-
-prop_charCategory :: GeneralCategory -> String -> Property
-prop_charCategory cat = checkChar (charCategory cat) p (lbl $ categoryName cat)
-  where p c = generalCategory c == cat
-
-prop_char :: Char -> String -> Property
-prop_char c = checkChar (char c) (== c) (tkn c)
-
-prop_char' :: Char -> String -> Property
-prop_char' c s = checkParser (char' c) r s
-  where h = head s
-        l | isLower c = [c, toUpper c]
-          | isUpper c = [c, toLower c]
-          | otherwise = [c]
-        r | null s         = posErr 0 s $ ueof : (etok <$> l)
-          | length s == 1 && (h `elemi` l) = Right h
-          | h `notElemi` l = posErr 0 s $ utok h : (etok <$> l)
-          | otherwise      = posErr 1 s [utok (s !! 1), eeof]
-
-prop_anyChar :: String -> Property
-prop_anyChar = checkChar anyChar (const True) (lbl "character")
-
-prop_oneOf :: String -> String -> Property
-prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing
-
-prop_oneOf' :: String -> String -> Property
-prop_oneOf' a = checkChar (oneOf' a) (`elemi` a) Nothing
-
-prop_noneOf :: String -> String -> Property
-prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing
-
-prop_noneOf' :: String -> String -> Property
-prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing
-
-prop_string :: String -> String -> Property
-prop_string a = checkString (string a) a (==)
-
-prop_string'_0 :: String -> String -> Property
-prop_string'_0 a = checkString (string' a) a casei
-
--- | Randomly change the case in the given string.
-
-fuzzyCase :: String -> Gen String
-fuzzyCase s = zipWith f s <$> vector (length s)
-  where f k True  = if isLower k then toUpper k else toLower k
-        f k False = k
-
-prop_string'_1 :: String -> Property
-prop_string'_1 a = forAll (fuzzyCase a) $ \s ->
-  checkString (string' a) a casei s
-
--- | Case-insensitive equality test for characters.
-
-casei :: Char -> Char -> Bool
-casei x y = toLower x == toLower y
-
--- | Case-insensitive 'elem'.
-
-elemi :: Char -> String -> Bool
-elemi c = any (casei c)
-
--- | Case-insensitive 'notElem'.
-
-notElemi :: Char -> String -> Bool
-notElemi c = not . elemi c
-
-tkn :: Char -> Maybe (ErrorItem Char)
-tkn = Just . Tokens . (:|[])
-
-lbl :: String -> Maybe (ErrorItem Char)
-lbl = Just . Label . NE.fromList

tests/Combinator.hs

@@ -1,233 +0,0 @@
---
--- QuickCheck tests for Megaparsec's generic parser combinators.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-module Combinator (tests) where
-
-import Control.Applicative
-import Data.Char (isLetter, isDigit)
-import Data.List (intersperse)
-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck
-
-import Text.Megaparsec.Char
-import Text.Megaparsec.Combinator
-
-import Util
-
-tests :: Test
-tests = testGroup "Generic parser combinators"
-  [ testProperty "combinator between"   prop_between
-  , testProperty "combinator choice"    prop_choice
-  , testProperty "combinator count"     prop_count
-  , testProperty "combinator count'"    prop_count'
-  , testProperty "combinator eitherP"   prop_eitherP
-  , testProperty "combinator endBy"     prop_endBy
-  , testProperty "combinator endBy1"    prop_endBy1
-  , testProperty "combinator manyTill"  prop_manyTill
-  , testProperty "combinator someTill"  prop_someTill
-  , testProperty "combinator option"    prop_option
-  , testProperty "combinator sepBy"     prop_sepBy
-  , testProperty "combinator sepBy1"    prop_sepBy1
-  , testProperty "combinator sepEndBy"  prop_sepEndBy
-  , testProperty "combinator sepEndBy1" prop_sepEndBy1
-  , testProperty "combinator skipMany"  prop_skipMany
-  , testProperty "combinator skipSome"  prop_skipSome ]
-
-prop_between :: String -> Char -> NonNegative Int -> String -> Property
-prop_between pre c n' post = checkParser p r s
-  where p = between (string pre) (string post) (many (char c))
-        n = getNonNegative n'
-        b = length $ takeWhile (== c) post
-        r | b > 0 = posErr (length pre + n + b) s $ etoks post : etok c :
-            [if length post == b
-              then ueof
-              else utoks [post !! b]]
-          | otherwise = Right z
-        z = replicate n c
-        s = pre ++ z ++ post
-
-prop_choice :: NonEmptyList Char -> Char -> Property
-prop_choice cs' s' = checkParser p r s
-  where cs = getNonEmpty cs'
-        p = choice $ char <$> cs
-        r | s' `elem` cs = Right s'
-          | otherwise    = posErr 0 s $ utok s' : (etok <$> cs)
-        s = [s']
-
-prop_count :: Int -> NonNegative Int -> Property
-prop_count n x' = checkParser p r s
-  where x = getNonNegative x'
-        p = count n (char 'x')
-        r = simpleParse (count' n n (char 'x')) s
-        s = replicate x 'x'
-
-prop_count' :: Int -> Int -> NonNegative Int -> Property
-prop_count' m n x' = checkParser p r s
-  where x = getNonNegative x'
-        p = count' m n (char 'x')
-        r | n <= 0 || m > n  =
-              if x == 0
-                then Right ""
-                else posErr 0 s [utok 'x', eeof]
-          | m <= x && x <= n = Right s
-          | x < m            = posErr x s [ueof, etok 'x']
-          | otherwise        = posErr n s [utok 'x', eeof]
-        s = replicate x 'x'
-
-prop_eitherP :: Char -> Property
-prop_eitherP ch = checkParser p r s
-  where p = eitherP letterChar digitChar
-        r | isLetter ch = Right (Left  ch)
-          | isDigit  ch = Right (Right ch)
-          | otherwise   = posErr 0 s [utok ch, elabel "letter", elabel "digit"]
-        s = pure ch
-
-prop_endBy :: NonNegative Int -> Char -> Property
-prop_endBy n' c = checkParser p r s
-  where n = getNonNegative n'
-        p = endBy (char 'a') (char '-')
-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']
-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']
-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a', eeof]
-          | c /= '-'           = posErr (g n) s $ utok c :
-            (if n > 0 then etok '-' else eeof) :
-            [etok 'a' | n == 0]
-          | otherwise = Right (replicate n 'a')
-        s = intersperse '-' (replicate n 'a') ++ [c]
-
-prop_endBy1 :: NonNegative Int -> Char -> Property
-prop_endBy1 n' c = checkParser p r s
-  where n = getNonNegative n'
-        p = endBy1 (char 'a') (char '-')
-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']
-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']
-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a']
-          | c /= '-'           = posErr (g n) s $ utok c :
-            [etok '-' | n > 0] ++ [etok 'a' | n == 0]
-          | otherwise = Right (replicate n 'a')
-        s = intersperse '-' (replicate n 'a') ++ [c]
-
-prop_manyTill :: NonNegative Int -> NonNegative Int
-              -> NonNegative Int -> Property
-prop_manyTill a' b' c' = checkParser p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
-        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar
-        r | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]
-          | otherwise = let (pre, post) = break (== 'c') s
-                        in Right (pre, drop 1 post)
-        s = abcRow a b c
-
-prop_someTill :: NonNegative Int -> NonNegative Int
-              -> NonNegative Int -> Property
-prop_someTill a' b' c' = checkParser p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
-        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar
-        r | null s    = posErr 0 s [ueof, elabel "letter"]
-          | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]
-          | s == "c"  = posErr 1 s [ueof, etok 'c', elabel "letter"]
-          | head s == 'c' = Right ("c", drop 2 s)
-          | otherwise = let (pre, post) = break (== 'c') s
-                        in Right (pre, drop 1 post)
-        s = abcRow a b c
-
-prop_option :: String -> String -> String -> Property
-prop_option d a s = checkParser p r s
-  where p = option d (string a)
-        r = simpleParse (fromMaybe d <$> optional (string a)) s
-
-prop_sepBy :: NonNegative Int -> Maybe Char -> Property
-prop_sepBy n' c' = checkParser p r s
-  where n = getNonNegative n'
-        c = fromJust c'
-        p = sepBy (char 'a') (char '-')
-        r | isNothing c' = Right (replicate n 'a')
-          | c == 'a' && n == 0 = Right "a"
-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]
-          | c == '-'  = posErr (length s) s [ueof, etok 'a']
-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]
-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
-
-prop_sepBy1 :: NonNegative Int -> Maybe Char -> Property
-prop_sepBy1 n' c' = checkParser p r s
-  where n = getNonNegative n'
-        c = fromJust c'
-        p = sepBy1 (char 'a') (char '-')
-        r | isNothing c' && n >= 1 = Right (replicate n 'a')
-          | isNothing c' = posErr 0 s [ueof, etok 'a']
-          | c == 'a' && n == 0 = Right "a"
-          | n == 0    = posErr 0 s [utok c, etok 'a']
-          | c == '-'  = posErr (length s) s [ueof, etok 'a']
-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]
-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
-
-prop_sepEndBy :: NonNegative Int -> Maybe Char -> Property
-prop_sepEndBy n' c' = checkParser p r s
-  where n = getNonNegative n'
-        c = fromJust c'
-        p = sepEndBy (char 'a') (char '-')
-        a = Right $ replicate n 'a'
-        r | isNothing c' = a
-          | c == 'a' && n == 0 = Right "a"
-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]
-          | c == '-'  = a
-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]
-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
-
-prop_sepEndBy1 :: NonNegative Int -> Maybe Char -> Property
-prop_sepEndBy1 n' c' = checkParser p r s
-  where n = getNonNegative n'
-        c = fromJust c'
-        p = sepEndBy1 (char 'a') (char '-')
-        a = Right $ replicate n 'a'
-        r | isNothing c' && n >= 1 = a
-          | isNothing c' = posErr 0 s [ueof, etok 'a']
-          | c == 'a' && n == 0 = Right "a"
-          | n == 0    = posErr 0 s [utok c, etok 'a']
-          | c == '-'  = a
-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]
-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
-
-prop_skipMany :: Char -> NonNegative Int -> String -> Property
-prop_skipMany c n' a = checkParser p r s
-  where p = skipMany (char c) *> string a
-        n = getNonNegative n'
-        r = simpleParse (many (char c) >> string a) s
-        s = replicate n c ++ a
-
-prop_skipSome :: Char -> NonNegative Int -> String -> Property
-prop_skipSome c n' a = checkParser p r s
-  where p = skipSome (char c) *> string a
-        n = getNonNegative n'
-        r = simpleParse (some (char c) >> string a) s
-        s = replicate n c ++ a
-
-g :: Int -> Int
-g x = x + if x > 0 then x - 1 else 0

tests/Error.hs

@@ -1,152 +0,0 @@
---
--- QuickCheck tests for Megaparsec's parse errors.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-{-# LANGUAGE CPP              #-}
-{-# OPTIONS -fno-warn-orphans #-}
-
-module Error (tests) where
-
-import Data.Function (on)
-import Data.List (isInfixOf)
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.Monoid ((<>))
-import Data.Set (Set)
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Set           as E
-
-import Test.Framework
-import Test.Framework.Providers.HUnit (testCase)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit (Assertion, (@?=))
-import Test.QuickCheck
-
-import Text.Megaparsec.Error
-import Text.Megaparsec.Pos
-
-import Util ()
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Foldable (Foldable, all)
-import Data.Monoid (mempty)
-import Prelude hiding (all)
-#endif
-
-tests :: Test
-tests = testGroup "Parse errors"
-  [ testProperty "monoid left identity"               prop_monoid_left_id
-  , testProperty "monoid right identity"              prop_monoid_right_id
-  , testProperty "monoid associativity"               prop_monoid_assoc
-  , testProperty "consistency of Show/Read"           prop_showReadConsistency
-  , testProperty "position of merged error"           prop_mergeErrorPos
-  , testProperty "unexpected items in merged error"   prop_mergeErrorUnexpected
-  , testProperty "expected items in merged error"     prop_mergeErrorExpected
-  , testProperty "custom items in merged error"       prop_mergeErrorCustom
-  , testCase     "showTokens (String instance)"       case_showTokens
-  , testCase     "rendering of unknown parse error"   case_ppUnknownError
-  , testProperty "source position in rendered error"  prop_ppSourcePos
-  , testProperty "unexpected items in rendered error" prop_ppUnexpected
-  , testProperty "expected items in rendered error"   prop_ppExpected
-  , testProperty "custom data in rendered error"      prop_ppCustom ]
-
-type PE = ParseError Char Dec
-
-prop_monoid_left_id :: PE -> Property
-prop_monoid_left_id x = mempty <> x === x .&&.
-  mempty { errorPos = errorPos x } <> x === x
-
-prop_monoid_right_id :: PE -> Property
-prop_monoid_right_id x = x <> mempty === x .&&.
-  mempty { errorPos = errorPos x } <> x === x
-
-prop_monoid_assoc :: PE -> PE -> PE -> Property
-prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z)
-
-prop_showReadConsistency :: PE -> Property
-prop_showReadConsistency x = read (show x) === x
-
-prop_mergeErrorPos :: PE -> PE -> Property
-prop_mergeErrorPos e1 e2 =
-  errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2)
-
-prop_mergeErrorUnexpected :: PE -> PE -> Property
-prop_mergeErrorUnexpected = checkMergedItems errorUnexpected
-
-prop_mergeErrorExpected :: PE -> PE -> Property
-prop_mergeErrorExpected = checkMergedItems errorExpected
-
-prop_mergeErrorCustom :: PE -> PE -> Property
-prop_mergeErrorCustom = checkMergedItems errorCustom
-
-checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property
-checkMergedItems f e1 e2 = f (e1 <> e2) === r
-  where r = case (compare `on` errorPos) e1 e2 of
-              LT -> f e2
-              EQ -> (E.union `on` f) e1 e2
-              GT -> f e1
-
-case_showTokens :: Assertion
-case_showTokens = mapM_ (\(x,y) -> showTokens (NE.fromList x) @?= y)
-  [ ("\r\n", "crlf newline")
-  , ("\0",   "null")
-  , ("\a",   "bell")
-  , ("\b",   "backspace")
-  , ("\t",   "tab")
-  , ("\n",   "newline")
-  , ("\v",   "vertical tab")
-  , ("\f",   "form feed")
-  , ("\r",   "carriage return")
-  , (" ",    "space")
-  , ("a",    "'a'")
-  , ("foo",  "\"foo\"") ]
-
-case_ppUnknownError :: Assertion
-case_ppUnknownError =
-  parseErrorPretty (err :: PE) @?= "1:1:\nunknown parse error\n"
-  where
-    err = ParseError
-      { errorPos        = initialPos "" :| []
-      , errorUnexpected = E.empty
-      , errorExpected   = E.empty
-      , errorCustom     = E.empty }
-
-prop_ppSourcePos :: PE -> Property
-prop_ppSourcePos = checkPresence errorPos sourcePosPretty
-
-prop_ppUnexpected :: PE -> Property
-prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent
-
-prop_ppExpected :: PE -> Property
-prop_ppExpected = checkPresence errorExpected showErrorComponent
-
-prop_ppCustom :: PE -> Property
-prop_ppCustom = checkPresence errorCustom showErrorComponent
-
-checkPresence :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property
-checkPresence g r e = property (all f (g e))
-  where rendered = parseErrorPretty e
-        f x = r x `isInfixOf` rendered

tests/Lexer.hs

@@ -1,409 +0,0 @@
---
--- QuickCheck tests for Megaparsec's lexer.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-{-# LANGUAGE CPP              #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections    #-}
-{-# LANGUAGE TypeFamilies     #-}
-
-module Lexer (tests) where
-
-import Control.Applicative (empty)
-import Control.Monad (void)
-import Data.Char
-  ( readLitChar
-  , showLitChar
-  , isDigit
-  , isAlphaNum
-  , isSpace
-  , toLower )
-import Data.List (findIndices, isInfixOf, find)
-import Data.Maybe
-import Data.Scientific (fromFloatDigits)
-import Numeric (showInt, showHex, showOct, showSigned)
-
-import Test.Framework
-import Test.Framework.Providers.HUnit (testCase)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit (Assertion)
-import Test.QuickCheck
-
-import Text.Megaparsec.Error
-import Text.Megaparsec.Lexer
-import Text.Megaparsec.Pos
-import Text.Megaparsec.Prim
-import Text.Megaparsec.String
-import qualified Text.Megaparsec.Char as C
-
-import Util
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*), (<*>), (<$))
-#endif
-
-tests :: Test
-tests = testGroup "Lexer"
-  [ testProperty "space combinator"       prop_space
-  , testProperty "symbol combinator"      prop_symbol
-  , testProperty "symbol' combinator"     prop_symbol'
-  , testCase     "case_skipLineCommentEof" case_skipLineCommentEof
-  , testCase     "skipBlockCommentNested" case_skipBlockCommentNested
-  , testProperty "indentLevel"            prop_indentLevel
-  , testProperty "incorrectIndent"        prop_incorrectIndent
-  , testProperty "indentGuard combinator" prop_indentGuard
-  , testProperty "nonIndented combinator" prop_nonIndented
-  , testProperty "indentBlock combinator" prop_indentBlock
-  , testProperty "indentBlock (many)"     prop_indentMany
-  , testProperty "lineFold"               prop_lineFold
-  , testProperty "charLiteral"            prop_charLiteral
-  , testProperty "integer"                prop_integer
-  , testProperty "decimal"                prop_decimal
-  , testProperty "hexadecimal"            prop_hexadecimal
-  , testProperty "octal"                  prop_octal
-  , testProperty "float 0"                prop_float_0
-  , testProperty "float 1"                prop_float_1
-  , testProperty "number 0"               prop_number_0
-  , testProperty "number 1"               prop_number_1
-  , testProperty "number 2 (signed)"      prop_number_2
-  , testProperty "signed"                 prop_signed ]
-
--- White space
-
-mkWhiteSpace :: Gen String
-mkWhiteSpace = concat <$> listOf whiteUnit
-  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]
-
-mkSymbol :: Gen String
-mkSymbol = (++) <$> symbolName <*> whiteChars
-
-mkInterspace :: String -> Int -> Gen String
-mkInterspace x n = oneof [si, mkIndent x n]
-  where si = (++ x) <$> listOf (elements " \t")
-
-mkIndent :: String -> Int -> Gen String
-mkIndent x n = (++) <$> mkIndent' x n <*> eol
-  where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]
-
-mkIndent' :: String -> Int -> Gen String
-mkIndent' x n = concat <$> sequence [spc, sym, tra]
-  where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]
-        tra = listOf itm
-        itm = elements " \t"
-        sym = return x
-
-whiteChars :: Gen String
-whiteChars = listOf (elements "\t\n ")
-
-whiteLine :: Gen String
-whiteLine = commentOut <$> arbitrary `suchThat` goodEnough
-  where commentOut x = "//" ++ x ++ "\n"
-        goodEnough x = '\n' `notElem` x
-
-whiteBlock :: Gen String
-whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough
-  where commentOut x = "/*" ++ x ++ "*/"
-        goodEnough x = not $ "*/" `isInfixOf` x
-
-symbolName :: Gen String
-symbolName = listOf $ arbitrary `suchThat` isAlphaNum
-
-sc :: Parser ()
-sc = space (void $ C.oneOf " \t") empty empty
-
-scn :: Parser ()
-scn = space (void C.spaceChar) l b
-  where l = skipLineComment "//"
-        b = skipBlockComment "/*" "*/"
-
-prop_space :: Property
-prop_space = forAll mkWhiteSpace (checkParser p r)
-  where p = scn
-        r = Right ()
-
-prop_symbol :: Maybe Char -> Property
-prop_symbol t = forAll mkSymbol $ \s ->
-  parseSymbol (symbol scn) id s t
-
-prop_symbol' :: Maybe Char -> Property
-prop_symbol' t = forAll mkSymbol $ \s ->
-  parseSymbol (symbol' scn) (fmap toLower) s t
-
-parseSymbol
-  :: (String -> Parser String)
-  -> (String -> String)
-  -> String
-  -> Maybe Char
-  -> Property
-parseSymbol p' f s' t = checkParser p r s
-  where p = p' (f g)
-        r | g == s || isSpace (last s) = Right g
-          | otherwise = posErr (length s - 1) s [utok (last s), eeof]
-        g = takeWhile (not . isSpace) s
-        s = s' ++ maybeToList t
-
-case_skipLineCommentEof :: Assertion
-case_skipLineCommentEof = checkCase p r s
-  where p = space (void C.spaceChar) (skipLineComment "//") empty <* eof
-        r = Right ()
-        s = "  // this line comment doesn't have a newline at the end "
-
-case_skipBlockCommentNested :: Assertion
-case_skipBlockCommentNested = checkCase p r s
-  where p = space (void C.spaceChar) empty
-              (skipBlockCommentNested "/*" "*/") <* eof
-        r = Right ()
-        s = " /* foo bar /* baz */ quux */ "
-
--- Indentation
-
-prop_indentLevel :: SourcePos -> Property
-prop_indentLevel pos = p /=\ sourceColumn pos
-  where p = setPosition pos >> indentLevel
-
-prop_incorrectIndent :: Ordering -> Pos -> Pos -> Property
-prop_incorrectIndent ord ref actual = checkParser p r s
-  where p = incorrectIndent ord ref actual :: Parser ()
-        r = posErr 0 s (ii ord ref actual)
-        s = ""
-
-prop_indentGuard :: NonNegative (Small Int) -> Property
-prop_indentGuard n =
-  forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) ->
-    let r | col0 <= pos1 = posErr 0 s (ii GT pos1 col0)
-          | col1 /= col0 = posErr (getIndent l1 + g 1) s (ii EQ col0 col1)
-          | col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2)
-          | otherwise    = Right ()
-        (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
-        fragments = [l0,l1,l2]
-        g x = sum (length <$> take x fragments)
-        s = concat fragments
-    in checkParser p r s
-  where mki = mkIndent sbla (getSmall $ getNonNegative n)
-        p  = ip GT pos1 >>=
-          \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn
-        ip = indentGuard scn
-        sp = void (symbol sc sbla <* C.eol)
-
-prop_nonIndented :: Property
-prop_nonIndented = forAll (mkIndent sbla 0) $ \s ->
-  let i = getIndent s
-      r | i == 0    = Right sbla
-        | otherwise = posErr i s (ii EQ pos1 (getCol s))
-  in checkParser p r s
-  where p = nonIndented scn (symbol scn sbla)
-
-prop_indentBlock :: Maybe (Positive (Small Int)) -> Property
-prop_indentBlock mn'' = forAll mkBlock $ \(l0,l1,l2,l3,l4) ->
-  let r | col1 <= col0 =
-          posErr (getIndent l1 + g 1) s [utok (head sblb), eeof]
-        | isJust mn && col1 /= ib' =
-          posErr (getIndent l1 + g 1) s (ii EQ ib' col1)
-        | col2 <= col1 =
-          posErr (getIndent l2 + g 2) s (ii GT col1 col2)
-        | col3 == col2 =
-          posErr (getIndent l3 + g 3) s [utok (head sblb), etoks sblc]
-        | col3 <= col0 =
-          posErr (getIndent l3 + g 3) s [utok (head sblb), eeof]
-        | col3 < col1 =
-          posErr (getIndent l3 + g 3) s (ii EQ col1 col3)
-        | col3 > col1 =
-          posErr (getIndent l3 + g 3) s (ii EQ col2 col3)
-        | col4 <= col3 =
-          posErr (getIndent l4 + g 4) s (ii GT col3 col4)
-        | otherwise = Right (sbla, [(sblb, [sblc]), (sblb, [sblc])])
-      (col0, col1, col2, col3, col4) =
-        (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)
-      fragments = [l0,l1,l2,l3,l4]
-      g x = sum (length <$> take x fragments)
-      s = concat fragments
-  in checkParser p r s
-  where mkBlock = do
-          l0 <- mkIndent sbla 0
-          l1 <- mkIndent sblb ib
-          l2 <- mkIndent sblc (ib + 2)
-          l3 <- mkIndent sblb ib
-          l4 <- mkIndent' sblc (ib + 2)
-          return (l0,l1,l2,l3,l4)
-        p = lvla
-        lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla
-        lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb
-        lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc
-        b    = symbol sc
-        l x  = return . (x,)
-        mn'  = getSmall . getPositive <$> mn''
-        mn   = unsafePos . fromIntegral <$> mn'
-        ib   = fromMaybe 2 mn'
-        ib'  = unsafePos (fromIntegral ib)
-
-prop_indentMany :: Property
-prop_indentMany = forAll (mkIndent sbla 0) (checkParser p r)
-  where r = Right (sbla, [])
-        p = lvla
-        lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla
-        lvlb = b sblb
-        b    = symbol sc
-        l x  = return . (x,)
-
-prop_lineFold :: Property
-prop_lineFold = forAll mkFold $ \(l0,l1,l2) ->
-  let r | end0 && col1 <= col0 =
-          posErr (getIndent l1 + g 1) s (ii GT col0 col1)
-        | end1 && col2 <= col0 =
-          posErr (getIndent l2 + g 2) s (ii GT col0 col2)
-        | otherwise = Right (sbla, sblb, sblc)
-      (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
-      (end0, end1)       = (getEnd l0, getEnd l1)
-      fragments = [l0,l1,l2]
-      g x = sum (length <$> take x fragments)
-      s = concat fragments
-  in checkParser p r s
-  where
-    mkFold = do
-      l0 <- mkInterspace sbla 0
-      l1 <- mkInterspace sblb 1
-      l2 <- mkInterspace sblc 1
-      return (l0,l1,l2)
-    p = lineFold scn $ \sc' -> do
-          a <- symbol sc' sbla
-          b <- symbol sc' sblb
-          c <- symbol scn sblc
-          return (a, b, c)
-    getEnd x = last x == '\n'
-
-getIndent :: String -> Int
-getIndent = length . takeWhile isSpace
-
-getCol :: String -> Pos
-getCol x = sourceColumn .
-  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x
-
-sbla, sblb, sblc :: String
-sbla = "aaa"
-sblb = "bbb"
-sblc = "ccc"
-
-ii :: Ordering -> Pos -> Pos -> [EC]
-ii ord ref actual = [cstm (DecIndentation ord ref actual)]
-
-pos1 :: Pos
-pos1 = unsafePos 1
-
--- Character and string literals
-
-prop_charLiteral :: String -> Bool -> Property
-prop_charLiteral t i = checkParser charLiteral r s
-  where b = listToMaybe $ readLitChar s
-        (h, g) = fromJust b
-        r | isNothing b = posErr 0 s $ elabel "literal character" :
-            [ if null s then ueof else utok (head s) ]
-          | null g      = Right h
-          | otherwise   = posErr l s [utok (head g), eeof]
-        l = length s - length g
-        s = if null t || i then t else showLitChar (head t) (tail t)
-
--- Numbers
-
-prop_integer :: NonNegative Integer -> Int -> Property
-prop_integer n' i = checkParser integer r s
-  where (r, s) = quasiCorrupted n' i showInt "integer"
-
-prop_decimal :: NonNegative Integer -> Int -> Property
-prop_decimal n' i = checkParser decimal r s
-  where (r, s) = quasiCorrupted n' i showInt "decimal integer"
-
-prop_hexadecimal :: NonNegative Integer -> Int -> Property
-prop_hexadecimal n' i = checkParser hexadecimal r s
-  where (r, s) = quasiCorrupted n' i showHex "hexadecimal integer"
-
-prop_octal :: NonNegative Integer -> Int -> Property
-prop_octal n' i = checkParser octal r s
-  where (r, s) = quasiCorrupted n' i showOct "octal integer"
-
-prop_float_0 :: NonNegative Double -> Property
-prop_float_0 n' = checkParser float r s
-  where n = getNonNegative n'
-        r = Right n
-        s = show n
-
-prop_float_1 :: Maybe (NonNegative Integer) -> Property
-prop_float_1 n' = checkParser float r s
-  where r | isNothing n' = posErr 0 s [ueof, elabel "floating point number"]
-          | otherwise    = posErr (length s) s
-            [ueof, etok '.', etok 'E', etok 'e', elabel "digit"]
-        s = maybe "" (show . getNonNegative) n'
-
-prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property
-prop_number_0 n' = checkParser number r s
-  where r = Right $ case n' of
-              Left  x -> fromIntegral . getNonNegative $ x
-              Right x -> fromFloatDigits . getNonNegative $ x
-        s = either (show . getNonNegative) (show . getNonNegative) n'
-
-prop_number_1 :: Property
-prop_number_1 = checkParser number r s
-  where r = posErr 0 s [ueof, elabel "number"]
-        s = ""
-
-prop_number_2 :: Either Integer Double -> Property
-prop_number_2 n = checkParser p r s
-  where p = signed (hidden C.space) number
-        r = Right $ case n of
-              Left  x -> fromIntegral x
-              Right x -> fromFloatDigits x
-        s = either show show n
-
-prop_signed :: Integer -> Int -> Bool -> Property
-prop_signed n i plus = checkParser p r s
-  where p = signed (hidden C.space) integer
-        r | i > length z = Right n
-          | otherwise = posErr i s $ utok '?' :
-            (if i <= 0 then [etok '+', etok '-'] else []) ++
-            [elabel $ if isNothing . find isDigit $ take i s
-                        then "integer"
-                        else "rest of integer"] ++
-            [eeof | i > head (findIndices isDigit s)]
-        z = let bar = showSigned showInt 0 n ""
-            in if n < 0 || plus then bar else '+' : bar
-        s = if i <= length z then take i z ++ "?" ++ drop i z else z
-
-quasiCorrupted
-  :: NonNegative Integer
-  -> Int
-  -> (Integer -> String -> String)
-  -> String
-  -> (Either (ParseError Char Dec) Integer, String)
-quasiCorrupted n' i shower l = (r, s)
-  where n = getNonNegative n'
-        r | i > length z = Right n
-          | otherwise    = posErr i s $ utok '?' :
-            [ eeof | i > 0 ] ++
-            [if i <= 0 || null l
-               then elabel l
-               else elabel $ "rest of " ++ l]
-        z = shower n ""
-        s = if i <= length z then take i z ++ "?" ++ drop i z else z

tests/Main.hs

@@ -1,51 +0,0 @@
---
--- QuickCheck tests for Megaparsec, main module.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-module Main (main) where
-
-import Test.Framework (defaultMain)
-
-import qualified Pos
-import qualified Error
-import qualified Prim
-import qualified Combinator
-import qualified Char
-import qualified Expr
-import qualified Perm
-import qualified Lexer
-
-main :: IO ()
-main = defaultMain
-  [ Pos.tests
-  , Error.tests
-  , Prim.tests
-  , Combinator.tests
-  , Char.tests
-  , Expr.tests
-  , Perm.tests
-  , Lexer.tests ]

tests/Perm.hs

@@ -1,103 +0,0 @@
---
--- QuickCheck tests for Megaparsec's permutation phrases parsers.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-module Perm (tests) where
-
-import Control.Applicative
-import Data.List (nub, elemIndices)
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck
-
-import Text.Megaparsec.Char
-import Text.Megaparsec.Lexer (integer)
-import Text.Megaparsec.Perm
-
-import Util
-
-tests :: Test
-tests = testGroup "Permutation phrases parsers"
-  [ testProperty "permutation parser pure" prop_pure
-  , testProperty "permutation test 0"      prop_perm_0
-  , testProperty "combinator (<$$>)"       prop_ddcomb ]
-
-data CharRows = CharRows
-  { getChars :: (Char, Char, Char)
-  , getInput :: String }
-  deriving (Eq, Show)
-
-instance Arbitrary CharRows where
-  arbitrary = do
-    chars@(a,b,c) <- arbitrary `suchThat` different
-    an            <- arbitrary
-    bn            <- arbitrary
-    cn            <- arbitrary
-    input <- concat <$> shuffle
-             [ replicate an a
-             , replicate bn b
-             , replicate cn c]
-    return $ CharRows chars input
-      where different (a,b,c) = let l = [a,b,c] in l == nub l
-
-prop_pure :: Integer -> Property
-prop_pure n = makePermParser p /=\ n
-  where p = id <$?> (succ n, pure n)
-
-prop_perm_0 :: String -> Char -> CharRows -> Property
-prop_perm_0 a' c' v = checkParser (makePermParser p) r s
-  where (a,b,c) = getChars v
-        p = (,,) <$?> (a', some (char a))
-                 <||> char b
-                 <|?> (c', char c)
-        r | length bis > 1 && (length cis <= 1 || head bis < head cis) =
-              posErr (bis !! 1) s $ [utok b, eeof] ++
-              [etok a | a `notElem` preb] ++
-              [etok c | c `notElem` preb]
-          | length cis > 1 =
-            posErr (cis !! 1) s $ [utok c] ++
-            [etok a | a `notElem` prec] ++
-            [if b `elem` prec then eeof else etok b]
-          | b `notElem` s = posErr (length s) s $ [ueof, etok b] ++
-                            [etok a | a `notElem` s || last s == a] ++
-                            [etok c | c `notElem` s]
-          | otherwise = Right ( if a `elem` s then filter (== a) s else a'
-                              , b
-                              , if c `elem` s then c else c' )
-        bis  = elemIndices b s
-        preb = take (bis !! 1) s
-        cis  = elemIndices c s
-        prec = take (cis !! 1) s
-        s    = getInput v
-
-prop_ddcomb :: NonNegative Integer -> Property
-prop_ddcomb n' = checkParser (makePermParser p) r s
-  where p = succ <$$> integer
-        r = Right (succ n)
-        n = getNonNegative n'
-        s = show n

tests/Pos.hs

@@ -1,121 +0,0 @@
---
--- QuickCheck tests for Megaparsec's textual source positions.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-{-# LANGUAGE CPP              #-}
-{-# OPTIONS -fno-warn-orphans #-}
-
-module Pos (tests) where
-
-import Control.Monad.Catch
-import Data.Function (on)
-import Data.List (isInfixOf, elemIndices)
-import Data.Semigroup ((<>))
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck
-
-import Text.Megaparsec.Pos
-import Util (updatePosString)
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Word (Word)
-#endif
-
-tests :: Test
-tests = testGroup "Textual source positions"
-  [ testProperty "creation of Pos (mkPos)"              prop_mkPos
-  , testProperty "creation of Pos (unsafePos)"          prop_unsafePos
-  , testProperty "consistency of Show/Read for Pos"     prop_showReadPos
-  , testProperty "Ord instance of Pos"                  prop_ordPos
-  , testProperty "Semigroup instance of Pos"            prop_semigroupPos
-  , testProperty "construction of initial position"     prop_initialPos
-  , testProperty "consistency of Show/Read for SourcePos" prop_showReadSourcePos
-  , testProperty "pretty-printing: visible file path"   prop_ppFilePath
-  , testProperty "pretty-printing: visible line"        prop_ppLine
-  , testProperty "pretty-printing: visible column"      prop_ppColumn
-  , testProperty "default updating of source position"  prop_defaultUpdatePos ]
-
-prop_mkPos :: Word -> Property
-prop_mkPos x' = case mkPos x' of
-  Left  e -> fromException e === Just InvalidPosException
-  Right x -> unPos x === x'
-
-prop_unsafePos :: Positive Word -> Property
-prop_unsafePos x' = unPos (unsafePos x) === x
-  where x = getPositive x'
-
-prop_showReadPos :: Pos -> Property
-prop_showReadPos x = read (show x) === x
-
-prop_ordPos :: Pos -> Pos -> Property
-prop_ordPos x y = compare x y === (compare `on` unPos) x y
-
-prop_semigroupPos :: Pos -> Pos -> Property
-prop_semigroupPos x y =
-  x <> y === unsafePos (unPos x + unPos y) .&&.
-  unPos (x <> y) === unPos x + unPos y
-
-prop_initialPos :: String -> Property
-prop_initialPos fp =
-  sourceName   x === fp          .&&.
-  sourceLine   x === unsafePos 1 .&&.
-  sourceColumn x === unsafePos 1
-  where x = initialPos fp
-
-prop_showReadSourcePos :: SourcePos -> Property
-prop_showReadSourcePos x = read (show x) === x
-
-prop_ppFilePath :: SourcePos -> Property
-prop_ppFilePath x = property $
-  sourceName x `isInfixOf` sourcePosPretty x
-
-prop_ppLine :: SourcePos -> Property
-prop_ppLine x = property $
-  (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x
-
-prop_ppColumn :: SourcePos -> Property
-prop_ppColumn x = property $
-  (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x
-
-prop_defaultUpdatePos :: Pos -> SourcePos -> String -> Property
-prop_defaultUpdatePos w pos "" = updatePosString w pos "" === pos
-prop_defaultUpdatePos w pos s =
-  sourceName updated === sourceName pos .&&.
-  unPos (sourceLine updated) === unPos (sourceLine pos) + inclines .&&.
-  cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` unPos w == 0))
-  where
-    updated  = updatePosString w pos s
-    cols     = unPos (sourceColumn updated)
-    newlines = elemIndices '\n' s
-    inclines = fromIntegral (length newlines)
-    total    = fromIntegral (length s)
-    mincols  =
-      if null newlines
-        then total + unPos (sourceColumn pos)
-        else total - fromIntegral (maximum newlines)

tests/Spec.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__ >= 708
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+#else
+
+module Spec (main) where
+
+main :: IO ()
+main = return ()
+#endif

tests/Test/Hspec/Megaparsec.hs

@@ -0,0 +1,377 @@
+-- |
+-- Module      :  Test.Hspec.Megaparsec
+-- Copyright   :  © 2016 Mark Karpov
+-- License     :  BSD 3 clause
+--
+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Utility functions for testing Megaparsec parsers with Hspec.
+
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+module Test.Hspec.Megaparsec
+  ( -- * Basic expectations
+    shouldParse
+  , parseSatisfies
+  , shouldSucceedOn
+  , shouldFailOn
+    -- * Testing of error messages
+  , shouldFailWith
+    -- * Error message construction
+    -- $errmsg
+  , err
+  , posI
+  , posN
+  , EC
+  , utok
+  , utoks
+  , ulabel
+  , ueof
+  , etok
+  , etoks
+  , elabel
+  , eeof
+  , cstm
+    -- * Incremental parsing
+  , failsLeaving
+  , succeedsLeaving
+  , initialState )
+where
+
+import Control.Monad (unless)
+import Data.Data (Data)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Proxy
+import Data.Semigroup
+import Data.Set (Set)
+import Data.Typeable (Typeable)
+import GHC.Generics
+import Test.Hspec.Expectations
+import Text.Megaparsec
+import Text.Megaparsec.Pos (defaultTabWidth)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Set           as E
+
+----------------------------------------------------------------------------
+-- Basic expectations
+
+-- | Create an expectation by saying what the result should be.
+--
+-- > parse letterChar "" "x" `shouldParse` 'x'
+
+shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a)
+  => Either (ParseError t e) a
+     -- ^ Result of parsing as returned by function like 'parse'
+  -> a                 -- ^ Desired result
+  -> Expectation
+r `shouldParse` v = case r of
+  Left e -> expectationFailure $ "expected: " ++ show v ++
+    "\nbut parsing failed with error:\n" ++ showParseError e
+  Right x -> unless (x == v) . expectationFailure $
+    "expected: " ++ show v ++ "\nbut got: " ++ show x
+
+-- | Create an expectation by saying that the parser should successfully
+-- parse a value and that the value should satisfy some predicate.
+--
+-- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length)
+
+parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
+  => Either (ParseError t e) a
+     -- ^ Result of parsing as returned by function like 'parse'
+  -> (a -> Bool)       -- ^ Predicate
+  -> Expectation
+r `parseSatisfies` p = case r of
+  Left e -> expectationFailure $
+    "expected a parsed value to check against the predicate" ++
+    "\nbut parsing failed with error:\n" ++ showParseError e
+  Right x -> unless (p x) . expectationFailure $
+    "the value did not satisfy the predicate: " ++ show x
+
+-- | Check that a parser fails on some given input.
+--
+-- > parse (char 'x') "" `shouldFailOn` "a"
+
+shouldFailOn :: Show a
+  => (s -> Either (ParseError t e) a)
+     -- ^ Parser that takes stream and produces result or error message
+  -> s                 -- ^ Input that the parser should fail on
+  -> Expectation
+p `shouldFailOn` s = shouldFail (p s)
+
+-- | Check that a parser succeeds on some given input.
+--
+-- > parse (char 'x') "" `shouldSucceedOn` "x"
+
+shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
+  => (s -> Either (ParseError t e) a)
+     -- ^ Parser that takes stream and produces result or error message
+  -> s                 -- ^ Input that the parser should succeed on
+  -> Expectation
+p `shouldSucceedOn` s = shouldSucceed (p s)
+
+----------------------------------------------------------------------------
+-- Testing of error messages
+
+-- | Create an expectation that parser should fail producing certain
+-- 'ParseError'. Use functions from "Text.Megaparsec.Error" to construct
+-- parse errors to check against. See "Text.Megaparsec.Pos" for functions to
+-- construct textual positions.
+--
+-- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x')
+
+shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
+  => Either (ParseError t e) a
+  -> ParseError t e
+  -> Expectation
+r `shouldFailWith` e = case r of
+  Left e' -> unless (e == e') . expectationFailure $
+    "the parser is expected to fail with:\n" ++ showParseError e ++
+    "but it failed with:\n" ++ showParseError e'
+  Right v -> expectationFailure $
+    "the parser is expected to fail, but it parsed: " ++ show v
+
+----------------------------------------------------------------------------
+-- Error message construction
+
+-- $errmsg When you wish to test error message on failure, the need to
+-- construct a error message for comparison arises. These helpers allow to
+-- construct virtually any sort of error message easily.
+
+-- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To
+-- create source position, two helpers are available: 'posI' and 'posN'.
+-- @'EC' t e@ is a monoid and can be built from primitives provided by this
+-- module, see below.
+--
+-- @since 0.3.0
+
+err
+  :: NonEmpty SourcePos -- ^ 'ParseError' position
+  -> EC t e             -- ^ Error components
+  -> ParseError t e     -- ^ Resulting 'ParseError'
+err pos (EC u e c) = ParseError pos u e c
+
+-- | Initial source position with empty file name.
+--
+-- @since 0.3.0
+
+posI :: NonEmpty SourcePos
+posI = initialPos "" :| []
+
+-- | @posN n s@ returns source position achieved by applying 'updatePos'
+-- method corresponding to type of stream @s@ @n@ times.
+--
+-- @since 0.3.0
+
+posN :: forall s n. (Stream s, Integral n)
+  => n
+  -> s
+  -> NonEmpty SourcePos
+posN n see = f (initialPos "") see n :| []
+  where
+    f p s !i =
+      if i > 0
+        then case uncons s of
+          Nothing -> p
+          Just (t,s') ->
+            let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t
+            in f p' s' (i - 1)
+        else p
+
+-- | Auxiliary type for construction of 'ParseError's. Note that it's a
+-- monoid.
+--
+-- @since 0.3.0
+
+data EC t e = EC
+  { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items
+  , ecExpected   :: Set (ErrorItem t) -- ^ Expected items
+  , _ecCustom    :: Set e             -- ^ Custom items
+  } deriving (Eq, Data, Typeable, Generic)
+
+instance (Ord t, Ord e) => Semigroup (EC t e) where
+  (EC u0 e0 c0) <> (EC u1 e1 c1) =
+    EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1)
+
+instance (Ord t, Ord e) => Monoid (EC t e) where
+  mempty  = EC E.empty E.empty E.empty
+  mappend = (<>)
+
+-- | Construct “unexpected token” error component.
+--
+-- @since 0.3.0
+
+utok :: (Ord t, Ord e) => t -> EC t e
+utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t }
+
+-- | Construct “unexpected tokens” error component. Empty string produces
+-- 'EndOfInput'.
+--
+-- @since 0.3.0
+
+utoks :: (Ord t, Ord e) => [t] -> EC t e
+utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t }
+
+-- | Construct “unexpected label” error component. Do not use with empty
+-- strings (for empty strings it's bottom).
+--
+-- @since 0.3.0
+
+ulabel :: (Ord t, Ord e) => String -> EC t e
+ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l }
+
+-- | Construct “unexpected end of input” error component.
+--
+-- @since 0.3.0
+
+ueof :: (Ord t, Ord e) => EC t e
+ueof = mempty { ecUnexpected = E.singleton EndOfInput }
+
+-- | Construct “expected token” error component.
+--
+-- @since 0.3.0
+
+etok :: (Ord t, Ord e) => t -> EC t e
+etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t }
+
+-- | Construct “expected tokens” error component. Empty string produces
+-- 'EndOfInput'.
+--
+-- @since 0.3.0
+
+etoks :: (Ord t, Ord e) => [t] -> EC t e
+etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t }
+
+-- | Construct “expected label” error component. Do not use with empty
+-- strings.
+--
+-- @since 0.3.0
+
+elabel :: (Ord t, Ord e) => String -> EC t e
+elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l }
+
+-- | Construct “expected end of input” error component.
+--
+-- @since 0.3.0
+
+eeof :: (Ord t, Ord e) => EC t e
+eeof = mempty { ecExpected = E.singleton EndOfInput }
+
+-- | Construct custom error component.
+--
+-- @since 0.3.0
+
+cstm :: e -> EC t e
+cstm e = EC E.empty E.empty (E.singleton e)
+
+----------------------------------------------------------------------------
+-- Incremental parsing
+
+-- | Check that a parser fails and leaves certain part of input
+-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
+-- that support incremental parsing.
+--
+-- > runParser' (many (char 'x') <* eof) (initialState "xxa")
+-- >   `failsLeaving` "a"
+--
+-- See also: 'initialState'.
+
+failsLeaving :: (Show a, Eq s, Show s, Stream s)
+  => (State s, Either (ParseError (Token s) e) a)
+     -- ^ Parser that takes stream and produces result along with actual
+     -- state information
+  -> s                 -- ^ Part of input that should be left unconsumed
+  -> Expectation
+(st,r) `failsLeaving` s =
+  shouldFail r >> checkUnconsumed s (stateInput st)
+
+-- | Check that a parser succeeds and leaves certain part of input
+-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
+-- that support incremental parsing.
+--
+-- > runParser' (many (char 'x')) (initialState "xxa")
+-- >   `succeedsLeaving` "a"
+--
+-- See also: 'initialState'.
+
+succeedsLeaving :: ( ShowToken (Token s)
+                   , ShowErrorComponent e
+                   , Show a
+                   , Eq s
+                   , Show s
+                   , Stream s )
+  => (State s, Either (ParseError (Token s) e) a)
+     -- ^ Parser that takes stream and produces result along with actual
+     -- state information
+  -> s                 -- ^ Part of input that should be left unconsumed
+  -> Expectation
+(st,r) `succeedsLeaving` s =
+  shouldSucceed r >> checkUnconsumed s (stateInput st)
+
+-- | Given input for parsing, construct initial state for parser (that is,
+-- with empty file name, default tab width and position at 1 line and 1
+-- column).
+
+initialState :: s -> State s
+initialState s = State s (initialPos "" :| []) defaultTabWidth
+
+----------------------------------------------------------------------------
+-- Helpers
+
+-- | Expectation that argument is result of a failed parser.
+
+shouldFail :: Show a => Either (ParseError t e) a -> Expectation
+shouldFail r = case r of
+  Left _ -> return ()
+  Right v -> expectationFailure $
+    "the parser is expected to fail, but it parsed: " ++ show v
+
+-- | Expectation that argument is result of a succeeded parser.
+
+shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
+  => Either (ParseError t e) a -> Expectation
+shouldSucceed r = case r of
+  Left e -> expectationFailure $
+    "the parser is expected to succeed, but it failed with:\n" ++
+    showParseError e
+  Right _ -> return ()
+
+-- | Compare two streams for equality and in the case of mismatch report it.
+
+checkUnconsumed :: (Eq s, Show s, Stream s)
+  => s                 -- ^ Expected unconsumed input
+  -> s                 -- ^ Actual unconsumed input
+  -> Expectation
+checkUnconsumed e a = unless (e == a) . expectationFailure $
+  "the parser is expected to leave unconsumed input: " ++ show e ++
+  "\nbut it left this: " ++ show a
+
+-- | Render parse error in a way that is suitable for inserting it in test
+-- suite report.
+
+showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)
+  => ParseError t e -> String
+showParseError = unlines . fmap ("  " ++) . lines . parseErrorPretty
+
+-- | Make a singleton non-empty list from a value.
+
+nes :: a -> NonEmpty a
+nes x = x :| []
+{-# INLINE nes #-}
+
+-- | Construct appropriate 'ErrorItem' representation for given token
+-- stream. Empty string produces 'EndOfInput'.
+
+canonicalizeTokens :: [t] -> ErrorItem t
+canonicalizeTokens ts =
+  case NE.nonEmpty ts of
+    Nothing -> EndOfInput
+    Just xs -> Tokens xs

tests/Test/Hspec/Megaparsec/AdHoc.hs

@@ -0,0 +1,185 @@
+--
+-- Tests for Megaparsec's expression parsers.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE CPP              #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes       #-}
+
+module Test.Hspec.Megaparsec.AdHoc
+  ( -- * Helpers to run parsers
+    prs
+  , prs'
+  , prs_
+  , grs
+  , grs'
+    -- * Working with source position
+  , updatePosString
+  , pos1
+  , nes
+    -- * Other
+  , abcRow
+  , toFirstMismatch )
+where
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans.Identity
+import Data.Foldable (foldl')
+import Data.List.NonEmpty (NonEmpty (..))
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Text.Megaparsec.Error
+import Text.Megaparsec.Pos
+import Text.Megaparsec.Prim
+import qualified Control.Monad.State.Lazy    as L
+import qualified Control.Monad.State.Strict  as S
+import qualified Control.Monad.Writer.Lazy   as L
+import qualified Control.Monad.Writer.Strict as S
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+
+----------------------------------------------------------------------------
+-- Helpers to run parsers
+
+-- | Apply parser to given input. This is a specialized version of 'parse'
+-- that assumes empty file name.
+
+prs
+  :: Parsec Dec String a -- ^ Parser to run
+  -> String            -- ^ Input for the parser
+  -> Either (ParseError Char Dec) a -- ^ Result of parsing
+prs p = parse p ""
+{-# INLINE prs #-}
+
+-- | Just like 'prs', but allows to inspect final state of the parser.
+
+prs'
+  :: Parsec Dec String a -- ^ Parser to run
+  -> String            -- ^ Input for the parser
+  -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing
+prs' p s = runParser' p (initialState s)
+{-# INLINE prs' #-}
+
+-- | Just like 'prs', but forces the parser to consume all input by adding
+-- 'eof':
+--
+-- > prs_ p = parse (p <* eof) ""
+
+prs_
+  :: Parsec Dec String a -- ^ Parser to run
+  -> String            -- ^ Input for the parser
+  -> Either (ParseError Char Dec) a -- ^ Result of parsing
+prs_ p = parse (p <* eof) ""
+{-# INLINE prs_ #-}
+
+-- | Just like 'prs', but interprets given parser as various monads (tries
+-- all supported monads transformers in turn).
+
+grs
+  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run
+  -> String            -- ^ Input for the parser
+  -> (Either (ParseError Char Dec) a -> Expectation)
+    -- ^ How to check result of parsing
+  -> Expectation
+grs p s r = do
+  r (prs p s)
+  r (prs (runIdentityT p)    s)
+  r (prs (runReaderT   p ()) s)
+  r (prs (L.evalStateT p ()) s)
+  r (prs (S.evalStateT p ()) s)
+  r (prs (evalWriterTL p)    s)
+  r (prs (evalWriterTS p)    s)
+
+-- | 'grs'' to 'grs' as 'prs'' to 'prs'.
+
+grs'
+  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run
+  -> String            -- ^ Input for the parser
+  -> ((State String, Either (ParseError Char Dec) a) -> Expectation)
+    -- ^ How to check result of parsing
+  -> Expectation
+grs' p s r = do
+  r (prs' p s)
+  r (prs' (runIdentityT p)    s)
+  r (prs' (runReaderT   p ()) s)
+  r (prs' (L.evalStateT p ()) s)
+  r (prs' (S.evalStateT p ()) s)
+  r (prs' (evalWriterTL p)    s)
+  r (prs' (evalWriterTS p)    s)
+
+evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
+evalWriterTL = liftM fst . L.runWriterT
+evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
+evalWriterTS = liftM fst . S.runWriterT
+
+----------------------------------------------------------------------------
+-- Working with source position
+
+-- | A helper function that is used to advance 'SourcePos' given a 'String'.
+
+updatePosString
+  :: Pos               -- ^ Tab width
+  -> SourcePos         -- ^ Initial position
+  -> String            -- ^ 'String' — collection of tokens to process
+  -> SourcePos         -- ^ Final position
+updatePosString w = foldl' f
+  where f p t = snd (defaultUpdatePos w p t)
+
+-- | Position with minimal value.
+
+pos1 :: Pos
+pos1 = unsafePos 1
+
+-- | Make a singleton non-empty list from a value.
+
+nes :: a -> NonEmpty a
+nes x = x :| []
+{-# INLINE nes #-}
+
+----------------------------------------------------------------------------
+-- Other
+
+-- | @abcRow a b c@ generates string consisting of character “a” repeated
+-- @a@ times, character “b” repeated @b@ times, and character “c” repeated
+-- @c@ times.
+
+abcRow :: Int -> Int -> Int -> String
+abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c'
+
+-- | Given a comparing function, get prefix of one string till first
+-- mismatch with another string (including first mismatching character).
+
+toFirstMismatch
+  :: (Char -> Char -> Bool) -- ^ Comparing function
+  -> String            -- ^ First string
+  -> String            -- ^ Second string
+  -> String            -- ^ Resulting prefix
+toFirstMismatch f str s = take (n + 1) s
+  where n = length (takeWhile (uncurry f) (zip str s))

tests/Text/Megaparsec/CharSpec.hs

@@ -0,0 +1,450 @@
+--
+-- Tests for Megaparsec's character parsers.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE CPP              #-}
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Text.Megaparsec.CharSpec (spec) where
+
+import Control.Monad
+import Data.Char
+import Data.List (partition, isPrefixOf)
+import Data.Monoid ((<>))
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Test.Hspec.Megaparsec.AdHoc
+import Test.QuickCheck
+import Text.Megaparsec.Char
+import Text.Megaparsec.Error
+import Text.Megaparsec.Prim
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+
+instance Arbitrary GeneralCategory where
+  arbitrary = elements [minBound..maxBound]
+
+spec :: Spec
+spec = do
+
+  describe "newline" $
+    checkStrLit "newline" "\n" (pure <$> newline)
+
+  describe "csrf" $
+    checkStrLit "crlf newline" "\r\n" crlf
+
+  describe "eol" $ do
+    context "when stream begins with a newline" $
+      it "succeeds returning the newline" $
+        property $ \s -> do
+          let s' = '\n' : s
+          prs  eol s' `shouldParse`     "\n"
+          prs' eol s' `succeedsLeaving` s
+    context "when stream begins with CRLF sequence" $
+      it "parses the CSRF sequence" $
+        property $ \s -> do
+          let s' = '\r' : '\n' : s
+          prs  eol s' `shouldParse`     "\r\n"
+          prs' eol s' `succeedsLeaving` s
+    context "when stream begins with '\\r', but it's not followed by '\\n'" $
+      it "signals correct parse error" $
+        property $ \ch -> ch /= '\n' ==> do
+          let s = ['\r',ch]
+          prs eol s `shouldFailWith` err posI
+            (utoks s <> utok '\r' <> elabel "end of line")
+    context "when input stream is '\\r'" $
+      it "signals correct parse error" $
+        prs eol "\r" `shouldFailWith` err posI
+          (utok '\r' <> elabel "end of line")
+    context "when stream does not begin with newline or CSRF sequence" $
+      it "signals correct parse error" $
+        property $ \ch s -> (ch `notElem` "\r\n") ==> do
+          let s' = ch : s
+          prs eol s' `shouldFailWith` err posI
+            (utok ch <> elabel "end of line")
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs eol "" `shouldFailWith` err posI
+          (ueof <> elabel "end of line")
+
+  describe "tab" $
+    checkStrLit "tab" "\t" (pure <$> tab)
+
+  describe "space" $
+    it "consumes it up to first non-space character" $
+      property $ \s -> do
+        let (s0,s1) = partition isSpace s
+            s' = s0 ++ s1
+        prs  space s' `shouldParse` ()
+        prs' space s' `succeedsLeaving` s1
+
+  describe "controlChar" $
+    checkCharPred "control character" isControl controlChar
+
+  describe "spaceChar" $
+    checkCharRange "white space" " \160\t\n\r\f\v" spaceChar
+
+  describe "upperChar" $
+    checkCharPred "uppercase letter" isUpper upperChar
+
+  describe "lowerChar" $
+    checkCharPred "lowercase letter" isLower lowerChar
+
+  describe "letterChar" $
+    checkCharPred "letter" isAlpha letterChar
+
+  describe "alphaNumChar" $
+    checkCharPred "alphanumeric character" isAlphaNum alphaNumChar
+
+  describe "printChar" $
+    checkCharPred "printable character" isPrint printChar
+
+  describe "digitChar" $
+    checkCharRange "digit" ['0'..'9'] digitChar
+
+  describe "octDigitChar" $
+    checkCharRange "octal digit" ['0'..'7'] octDigitChar
+
+  describe "hexDigitChar" $
+    checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar
+
+  describe "markChar" $
+    checkCharRange "mark character" "" markChar
+
+  describe "numberChar" $
+    let xs = "\185\178\179\188\189\190" ++ ['0'..'9']
+    in checkCharRange "numeric character" xs numberChar
+
+  describe "punctuationChar" $
+    checkCharPred "punctuation" isPunctuation punctuationChar
+
+  describe "symbolChar" $
+#if MIN_VERSION_base(4,8,0)
+    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar
+#else
+    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar
+#endif
+  describe "separatorChar" $
+    checkCharRange "separator" " \160" separatorChar
+
+  describe "asciiChar" $
+    checkCharPred "ASCII character" isAscii asciiChar
+
+  describe "latin1Char" $ do
+    context "when stream begins with Latin-1 character" $
+      it "parses the Latin-1 character" $
+        property $ \ch s -> isLatin1 ch ==> do
+          let s' = ch : s
+          prs  latin1Char s' `shouldParse`     ch
+          prs' latin1Char s' `succeedsLeaving` s
+    context "when stream does not begin with Latin-1 character" $
+      it "signals correct parse error" $ do
+        prs  latin1Char "б" `shouldFailWith`
+          err posI (utok 'б' <> elabel "Latin-1 character")
+        prs' latin1Char "в" `failsLeaving`   "в"
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character")
+
+  describe "charCategory" $ do
+    context "when parser corresponding to general category of next char is used" $
+      it "succeeds" $
+        property $ \ch s -> do
+          let s' = ch : s
+              g  = generalCategory ch
+          prs  (charCategory g) s' `shouldParse`     ch
+          prs' (charCategory g) s' `succeedsLeaving` s
+    context "when parser's category does not match next character's category" $
+      it "fails" $
+        property $ \g ch s -> (generalCategory ch /= g) ==> do
+          let s' = ch : s
+          prs  (charCategory g) s' `shouldFailWith`
+            err posI (utok ch <> elabel (categoryName g))
+          prs' (charCategory g) s' `failsLeaving` s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \g ->
+          prs (charCategory g) "" `shouldFailWith`
+            err posI (ueof <> elabel (categoryName g))
+
+  describe "char" $ do
+    context "when stream begins with the character specified as argument" $
+      it "parses the character" $
+        property $ \ch s -> do
+          let s' = ch : s
+          prs  (char ch) s' `shouldParse` ch
+          prs' (char ch) s' `succeedsLeaving` s
+    context "when stream does not begin with the character specified as argument" $
+      it "signals correct parse error" $
+        property $ \ch ch' s -> ch /= ch' ==> do
+          let s' = ch' : s
+          prs  (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch)
+          prs' (char ch) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \ch ->
+          prs  (char ch) "" `shouldFailWith` err posI (ueof <> etok ch)
+
+  describe "char'" $ do
+    context "when stream begins with the character specified as argument" $
+      it "parses the character" $
+        property $ \ch s -> do
+          let sl = toLower ch : s
+              su = toUpper ch : s
+          prs  (char' ch) sl `shouldParse`     toLower ch
+          prs  (char' ch) su `shouldParse`     toUpper ch
+          prs' (char' ch) sl `succeedsLeaving` s
+          prs' (char' ch) su `succeedsLeaving` s
+    context "when stream does not begin with the character specified as argument" $
+      it "signals correct parse error" $
+        property $ \ch ch' s -> toLower ch /= toLower ch' ==> do
+          let s' = ch' : s
+              ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch)
+          prs  (char' ch) s' `shouldFailWith` err posI ms
+          prs' (char' ch) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \ch -> do
+          let ms = ueof <> etok (toLower ch) <> etok (toUpper ch)
+          prs  (char' ch) "" `shouldFailWith` err posI ms
+
+  describe "anyChar" $ do
+    context "when stream is not empty" $
+      it "succeeds consuming next character in the stream" $
+        property $ \ch s -> do
+          let s' = ch : s
+          prs  anyChar s' `shouldParse`     ch
+          prs' anyChar s' `succeedsLeaving` s
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character")
+
+  describe "oneOf" $ do
+    context "when stream begins with one of specified characters" $
+      it "parses the character" $
+        property $ \chs' n s -> do
+          let chs = getNonEmpty chs'
+              ch  = chs !! (getNonNegative n `rem` length chs)
+              s'  = ch : s
+          prs  (oneOf chs) s' `shouldParse`     ch
+          prs' (oneOf chs) s' `succeedsLeaving` s
+    context "when stream does not begin with any of specified characters" $
+      it "signals correct parse error" $
+        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do
+          let s' = ch : s
+          prs  (oneOf chs) s' `shouldFailWith` err posI (utok ch)
+          prs' (oneOf chs) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \chs ->
+          prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof
+
+  describe "oneOf'" $ do
+    context "when stream begins with one of specified characters" $
+      it "parses the character" $
+        property $ \chs' n s -> do
+          let chs = getNonEmpty chs'
+              ch  = chs !! (getNonNegative n `rem` length chs)
+              sl  = toLower ch : s
+              su  = toUpper ch : s
+          prs  (oneOf' chs) sl `shouldParse`     toLower ch
+          prs  (oneOf' chs) su `shouldParse`     toUpper ch
+          prs' (oneOf' chs) sl `succeedsLeaving` s
+          prs' (oneOf' chs) su `succeedsLeaving` s
+    context "when stream does not begin with any of specified characters" $
+      it "signals correct parse error" $
+        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do
+          let s' = ch : s
+          prs  (oneOf' chs) s' `shouldFailWith` err posI (utok ch)
+          prs' (oneOf' chs) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \chs ->
+          prs (oneOf' (chs :: String)) "" `shouldFailWith` err posI ueof
+
+  describe "noneOf" $ do
+    context "when stream does not begin with any of specified characters" $
+      it "parses the character" $
+        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do
+          let s' = ch : s
+          prs  (noneOf chs) s' `shouldParse`     ch
+          prs' (noneOf chs) s' `succeedsLeaving` s
+    context "when stream begins with one of specified characters" $
+      it "signals correct parse error" $
+        property $ \chs' n s -> do
+          let chs = getNonEmpty chs'
+              ch  = chs !! (getNonNegative n `rem` length chs)
+              s'  = ch : s
+          prs  (noneOf chs) s' `shouldFailWith` err posI (utok ch)
+          prs' (noneOf chs) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \chs ->
+          prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof
+
+  describe "noneOf'" $ do
+    context "when stream does not begin with any of specified characters" $
+      it "parses the character" $
+        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do
+          let sl  = toLower ch : s
+              su  = toUpper ch : s
+          prs  (noneOf' chs) sl `shouldParse`     toLower ch
+          prs  (noneOf' chs) su `shouldParse`     toUpper ch
+          prs' (noneOf' chs) sl `succeedsLeaving` s
+          prs' (noneOf' chs) su `succeedsLeaving` s
+    context "when stream begins with one of specified characters" $
+      it "signals correct parse error" $
+        property $ \chs' n s -> do
+          let chs = getNonEmpty chs'
+              ch  = chs !! (getNonNegative n `rem` length chs)
+              s'  = ch : s
+          prs  (noneOf' chs) s' `shouldFailWith` err posI (utok ch)
+          prs' (noneOf' chs) s' `failsLeaving`   s'
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        property $ \chs ->
+          prs (noneOf' (chs :: String)) "" `shouldFailWith` err posI ueof
+
+  describe "string" $ do
+    context "when stream is prefixed with given string" $
+      it "parses the string" $
+        property $ \str s -> do
+          let s' = str ++ s
+          prs  (string str) s' `shouldParse`     str
+          prs' (string str) s' `succeedsLeaving` s
+    context "when stream is not prefixed with given string" $
+      it "signals correct parse error" $
+        property $ \str s -> not (str `isPrefixOf` s) ==> do
+          let n = length (takeWhile (uncurry (==)) (zip str s)) + 1
+              common = take n s
+          prs  (string str) s `shouldFailWith` err posI (utoks common <> etoks str)
+
+  describe "string'" $ do
+    context "when stream is prefixed with given string" $
+      it "parses the string" $
+        property $ \str s ->
+          forAll (fuzzyCase str) $ \str' -> do
+            let s' = str' ++ s
+            prs  (string' str) s' `shouldParse`     str'
+            prs' (string' str) s' `succeedsLeaving` s
+    context "when stream is not prefixed with given string" $
+      it "signals correct parse error" $
+        property $ \str s -> not (str `isPrefixOfI` s) ==> do
+          let n = length (takeWhile (uncurry casei) (zip str s)) + 1
+              common = take n s
+          prs  (string' str) s `shouldFailWith` err posI (utoks common <> etoks str)
+
+----------------------------------------------------------------------------
+-- Helpers
+
+checkStrLit :: String -> String -> Parsec Dec String String -> SpecWith ()
+checkStrLit name ts p = do
+  context ("when stream begins with " ++ name) $
+    it ("parses the " ++ name) $
+      property $ \s -> do
+        let s' = ts ++ s
+        prs  p s' `shouldParse`     ts
+        prs' p s' `succeedsLeaving` s
+  context ("when stream does not begin with " ++ name) $
+    it "signals correct parse error" $
+      property $ \ch s -> ch /= head ts ==> do
+       let s' = ch : s
+       prs  p s' `shouldFailWith` err posI (utok ch <> etoks ts)
+       prs' p s' `failsLeaving`   s'
+  context "when stream is empty" $
+    it "signals correct parse error" $
+      prs p "" `shouldFailWith` err posI (ueof <> etoks ts)
+
+checkCharPred :: String -> (Char -> Bool) -> Parsec Dec String Char -> SpecWith ()
+checkCharPred name f p = do
+  context ("when stream begins with " ++ name) $
+    it ("parses the " ++ name) $
+      property $ \ch s -> f ch ==> do
+        let s' = ch : s
+        prs  p s' `shouldParse`     ch
+        prs' p s' `succeedsLeaving` s
+  context ("when stream does not begin with " ++ name) $
+    it "signals correct parse error" $
+      property $ \ch s -> not (f ch) ==> do
+       let s' = ch : s
+       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)
+       prs' p s' `failsLeaving`   s'
+  context "when stream is empty" $
+    it "signals correct parse error" $
+      prs p "" `shouldFailWith` err posI (ueof <> elabel name)
+
+checkCharRange :: String -> String -> Parsec Dec String Char -> SpecWith ()
+checkCharRange name tchs p = do
+  forM_ tchs $ \tch ->
+    context ("when stream begins with " ++ showTokens (nes tch)) $
+      it ("parses the " ++ showTokens (nes tch)) $
+        property $ \s -> do
+          let s' = tch : s
+          prs  p s' `shouldParse`     tch
+          prs' p s' `succeedsLeaving` s
+  context ("when stream does not begin with " ++ name) $
+    it "signals correct parse error" $
+      property $ \ch s -> ch `notElem` tchs ==> do
+       let s' = ch : s
+       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)
+       prs' p s' `failsLeaving`   s'
+  context "when stream is empty" $
+    it "signals correct parse error" $
+      prs p "" `shouldFailWith` err posI (ueof <> elabel name)
+
+-- | Randomly change the case in the given string.
+
+fuzzyCase :: String -> Gen String
+fuzzyCase s = zipWith f s <$> vector (length s)
+  where f k True  = if isLower k then toUpper k else toLower k
+        f k False = k
+
+-- | Case-insensitive equality test for characters.
+
+casei :: Char -> Char -> Bool
+casei x y = toUpper x == toUpper y
+
+-- | Case-insensitive 'elem'.
+
+elemi :: Char -> String -> Bool
+elemi c = any (casei c)
+
+-- | Case-insensitive 'notElem'.
+
+notElemi :: Char -> String -> Bool
+notElemi c = not . elemi c
+
+-- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff
+-- the first list is a prefix of the second with case-insensitive
+-- comparison.
+
+isPrefixOfI :: String -> String -> Bool
+isPrefixOfI [] _  =  True
+isPrefixOfI _  [] =  False
+isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys

tests/Text/Megaparsec/CombinatorSpec.hs

@@ -0,0 +1,256 @@
+--
+-- Tests for Megaparsec's generic parser combinators.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE MultiWayIf #-}
+
+module Text.Megaparsec.CombinatorSpec (spec) where
+
+import Control.Applicative
+import Data.Char (isLetter, isDigit)
+import Data.List (intersperse)
+import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)
+import Data.Monoid
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Test.Hspec.Megaparsec.AdHoc
+import Test.QuickCheck
+import Text.Megaparsec.Char
+import Text.Megaparsec.Combinator
+
+spec :: Spec
+spec = do
+
+  describe "between" . it "works" . property $ \pre c n' post -> do
+    let p = between (string pre) (string post) (many (char c))
+        n = getNonNegative n'
+        b = length (takeWhile (== c) post)
+        z = replicate n c
+        s = pre ++ z ++ post
+    if b > 0
+      then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s)
+        ( etoks post <> etok c <>
+          (if length post == b then ueof else utoks [post !! b]) )
+      else prs_ p s `shouldParse` z
+
+  describe "choice" . it "works" . property $ \cs' s' -> do
+    let cs = getNonEmpty cs'
+        p = choice (char <$> cs)
+        s = [s']
+    if s' `elem` cs
+      then prs_ p s `shouldParse` s'
+      else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs))
+
+  describe "count" . it "works" . property $ \n x' -> do
+    let x = getNonNegative x'
+        p = count n (char 'x')
+        p' = count' n n (char 'x')
+        s = replicate x 'x'
+    prs_ p s `shouldBe` prs_ p' s
+
+  describe "count'" . it "works" . property $ \m n x' -> do
+    let x = getNonNegative x'
+        p = count' m n (char 'x')
+        s = replicate x 'x'
+    if | n <= 0 || m > n ->
+         if x == 0
+           then prs_ p s `shouldParse` ""
+           else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)
+       | m <= x && x <= n ->
+         prs_ p s `shouldParse` s
+       | x < m ->
+         prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')
+       | otherwise ->
+         prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)
+
+  describe "eitherP" . it "works" . property $ \ch -> do
+    let p = eitherP letterChar digitChar
+        s = pure ch
+    if | isLetter ch -> prs_ p s `shouldParse` Left ch
+       | isDigit  ch -> prs_ p s `shouldParse` Right ch
+       | otherwise   -> prs_ p s `shouldFailWith`
+         err posI (utok ch <> elabel "letter" <> elabel "digit")
+
+  describe "endBy" . it "works" . property $ \n' c -> do
+    let n = getNonNegative n'
+        p = endBy (char 'a') (char '-')
+        s = intersperse '-' (replicate n 'a') ++ [c]
+    if | c == 'a' && n == 0 ->
+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')
+       | c == 'a' ->
+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')
+       | c == '-' && n == 0 ->
+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)
+       | c /= '-' ->
+         prs_ p s `shouldFailWith` err (posN (g n) s)
+           ( utok c <>
+             (if n > 0 then etok '-' else eeof) <>
+             (if n == 0 then etok 'a' else mempty) )
+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'
+
+  describe "endBy1" . it "works" . property $ \n' c -> do
+    let n = getNonNegative n'
+        p = endBy1 (char 'a') (char '-')
+        s = intersperse '-' (replicate n 'a') ++ [c]
+    if | c == 'a' && n == 0 ->
+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')
+       | c == 'a' ->
+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')
+       | c == '-' && n == 0 ->
+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')
+       | c /= '-' ->
+         prs_ p s `shouldFailWith` err (posN (g n) s)
+           ( utok c <>
+             (if n > 0 then etok '-' else mempty) <>
+             (if n == 0 then etok 'a' else mempty) )
+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'
+
+  describe "manyTill" . it "works" . property $ \a' b' c' -> do
+    let [a,b,c] = getNonNegative <$> [a',b',c']
+        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar
+        s = abcRow a b c
+    if c == 0
+      then prs_ p s `shouldFailWith` err (posN (a + b) s)
+           (ueof <> etok 'c' <> elabel "letter")
+      else let (pre, post) = break (== 'c') s
+           in prs_ p s `shouldParse` (pre, drop 1 post)
+
+  describe "someTill" . it "works" . property $ \a' b' c' -> do
+    let [a,b,c] = getNonNegative <$> [a',b',c']
+        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar
+        s = abcRow a b c
+    if | null s ->
+         prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")
+       | c == 0 ->
+         prs_ p s `shouldFailWith` err (posN (a + b) s)
+           (ueof <> etok 'c' <> elabel "letter")
+       | s == "c" ->
+         prs_ p s `shouldFailWith` err
+           (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")
+       | head s == 'c' ->
+         prs_ p s `shouldParse` ("c", drop 2 s)
+       | otherwise ->
+         let (pre, post) = break (== 'c') s
+         in prs_ p s `shouldParse` (pre, drop 1 post)
+
+  describe "option" . it "works" . property $ \d a s -> do
+    let p = option d (string a)
+        p' = fromMaybe d <$> optional (string a)
+    prs_ p s `shouldBe` prs_ p' s
+
+  describe "sepBy" . it "works" . property $ \n' c' -> do
+    let n = getNonNegative n'
+        c = fromJust c'
+        p = sepBy (char 'a') (char '-')
+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
+    if | isNothing c' ->
+         prs_ p s `shouldParse` replicate n 'a'
+       | c == 'a' && n == 0 ->
+         prs_ p s `shouldParse` "a"
+       | n == 0 ->
+         prs_ p s `shouldFailWith` err posI
+           (utok c <> etok 'a' <> eeof)
+       | c == '-' ->
+         prs_ p s `shouldFailWith` err (posN (length s) s)
+           (ueof <> etok 'a')
+       | otherwise ->
+         prs_ p s `shouldFailWith` err (posN (g n) s)
+           (utok c <> etok '-' <> eeof)
+
+  describe "sepBy1" . it "works" . property $ \n' c' -> do
+    let n = getNonNegative n'
+        c = fromJust c'
+        p = sepBy1 (char 'a') (char '-')
+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
+    if | isNothing c' && n >= 1 ->
+         prs_ p s `shouldParse` replicate n 'a'
+       | isNothing c' ->
+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')
+       | c == 'a' && n == 0 ->
+         prs_ p s `shouldParse` "a"
+       | n == 0 ->
+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')
+       | c == '-' ->
+         prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')
+       | otherwise ->
+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)
+
+  describe "sepEndBy" . it "works" . property $ \n' c' -> do
+    let n = getNonNegative n'
+        c = fromJust c'
+        p = sepEndBy (char 'a') (char '-')
+        a = replicate n 'a'
+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
+    if | isNothing c' ->
+         prs_ p s `shouldParse` a
+       | c == 'a' && n == 0 ->
+         prs_ p s `shouldParse` "a"
+       | n == 0 ->
+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)
+       | c == '-' ->
+         prs_ p s `shouldParse` a
+       | otherwise ->
+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)
+
+  describe "sepEndBy1" . it "works" . property $ \n' c' -> do
+    let n = getNonNegative n'
+        c = fromJust c'
+        p = sepEndBy1 (char 'a') (char '-')
+        a = replicate n 'a'
+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'
+    if | isNothing c' && n >= 1 ->
+         prs_ p s `shouldParse` a
+       | isNothing c' ->
+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')
+       | c == 'a' && n == 0 ->
+         prs_ p s `shouldParse` "a"
+       | n == 0 ->
+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')
+       | c == '-' ->
+         prs_ p s `shouldParse` a
+       | otherwise ->
+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)
+
+  describe "skipMany" . it "works" . property $ \c n' a -> do
+    let p = skipMany (char c) *> string a
+        n = getNonNegative n'
+        p' = many (char c) >> string a
+        s = replicate n c ++ a
+    prs_ p s `shouldBe` prs_ p' s
+
+  describe "skipSome" . it "works" . property $ \c n' a -> do
+    let p = skipSome (char c) *> string a
+        n = getNonNegative n'
+        p' = some (char c) >> string a
+        s = replicate n c ++ a
+    prs_ p s `shouldBe` prs_ p' s
+
+----------------------------------------------------------------------------
+-- Helpers
+
+g :: Int -> Int
+g x = x + if x > 0 then x - 1 else 0

tests/Text/Megaparsec/ErrorSpec.hs

@@ -0,0 +1,214 @@
+--
+-- Tests for Megaparsec's parse errors.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE CPP              #-}
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Text.Megaparsec.ErrorSpec (spec) where
+
+import Data.Char (isControl, isSpace)
+import Data.Function (on)
+import Data.List (isInfixOf, isSuffixOf)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Monoid
+import Data.Set (Set)
+import Test.Hspec
+import Test.QuickCheck
+import Text.Megaparsec.Error
+import Text.Megaparsec.Pos
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup     as S
+import qualified Data.Set           as E
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable (Foldable, all)
+import Prelude hiding (all)
+#endif
+
+type PE = ParseError Char Dec
+
+spec :: Spec
+spec = do
+
+  describe "Semigroup instance of ParseError" $
+    it "associativity" $
+      property $ \x y z ->
+        (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE)
+
+  describe "Monoid instance of ParseError" $ do
+    it "left identity" $
+      property $ \x ->
+        mempty <> x === (x :: PE)
+    it "right identity" $
+      property $ \x ->
+        x <> mempty === (x :: PE)
+    it "associativity" $
+      property $ \x y z ->
+        (x <> y) <> z === (x <> (y <> z) :: PE)
+
+  describe "Read and Show instances of ParseError" $
+    it "printed representation of ParseError can be read back" $
+      property $ \x ->
+        read (show x) === (x :: PE)
+
+  describe "error merging with (<>)" $ do
+    it "selects greater source position" $
+      property $ \x y ->
+        errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)
+    it "merges unexpected items correctly" $
+      property (checkMergedItems errorUnexpected)
+    it "merges expected items correctly" $
+      property (checkMergedItems errorExpected)
+    it "merges custom items correctly" $
+      property (checkMergedItems errorCustom)
+
+  describe "showTokens (Char instance)" $ do
+    let f x y = showTokens (NE.fromList x) `shouldBe` y
+    it "shows CRLF newline correctly"
+      (f "\r\n" "crlf newline")
+    it "shows null byte correctly"
+      (f "\NUL" "null (control character)")
+    it "shows start of heading correctly"
+      (f "\SOH" "start of heading (control character)")
+    it "shows start of text correctly"
+      (f "\STX" "start of text (control character)")
+    it "shows end of text correctly"
+      (f "\ETX" "end of text (control character)")
+    it "shows end of transmission correctly"
+      (f "\EOT" "end of transmission (control character)")
+    it "shows enquiry correctly"
+      (f "\ENQ" "enquiry (control character)")
+    it "shows acknowledge correctly"
+      (f "\ACK" "acknowledge (control character)")
+    it "shows bell correctly"
+      (f "\BEL" "bell (control character)")
+    it "shows backspace correctly"
+      (f "\BS" "backspace")
+    it "shows tab correctly"
+      (f "\t" "tab")
+    it "shows newline correctly"
+      (f "\n" "newline")
+    it "shows vertical tab correctly"
+      (f "\v" "vertical tab")
+    it "shows form feed correctly"
+      (f "\f" "form feed (control character)")
+    it "shows carriage return correctly"
+      (f "\r" "carriage return")
+    it "shows shift out correctly"
+      (f "\SO" "shift out (control character)")
+    it "shows shift in correctly"
+      (f "\SI" "shift in (control character)")
+    it "shows data link escape correctly"
+      (f "\DLE" "data link escape (control character)")
+    it "shows device control one correctly"
+      (f "\DC1" "device control one (control character)")
+    it "shows device control two correctly"
+      (f "\DC2" "device control two (control character)")
+    it "shows device control three correctly"
+      (f "\DC3" "device control three (control character)")
+    it "shows device control four correctly"
+      (f "\DC4" "device control four (control character)")
+    it "shows negative acknowledge correctly"
+      (f "\NAK" "negative acknowledge (control character)")
+    it "shows synchronous idle correctly"
+      (f "\SYN" "synchronous idle (control character)")
+    it "shows end of transmission block correctly"
+      (f "\ETB" "end of transmission block (control character)")
+    it "shows cancel correctly"
+      (f "\CAN" "cancel (control character)")
+    it "shows end of medium correctly"
+      (f "\EM"  "end of medium (control character)")
+    it "shows substitute correctly"
+      (f "\SUB" "substitute (control character)")
+    it "shows escape correctly"
+      (f "\ESC" "escape (control character)")
+    it "shows file separator correctly"
+      (f "\FS"  "file separator (control character)")
+    it "shows group separator correctly"
+      (f "\GS"  "group separator (control character)")
+    it "shows record separator correctly"
+      (f "\RS"  "record separator (control character)")
+    it "shows unit separator correctly"
+      (f "\US"  "unit separator (control character)")
+    it "shows delete correctly"
+      (f "\DEL" "delete (control character)")
+    it "shows space correctly"
+      (f " "    "space")
+    it "shows non-breaking space correctly"
+      (f "\160" "non-breaking space")
+    it "shows other single characters in single quotes" $
+      property $ \ch ->
+        not (isControl ch) && not (isSpace ch) ==>
+          showTokens (ch :| []) === ['\'',ch,'\'']
+    it "shows strings in double quotes" $
+      property $ \str ->
+        (length str > 1) && (str /= "\r\n") ==>
+          showTokens (NE.fromList str) === ("\"" ++ str ++"\"")
+
+  describe "parseErrorPretty" $ do
+    it "shows unknown ParseError correctly" $
+      parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"
+    it "result always ends with a newline" $
+      property $ \x ->
+        parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)
+    it "result contains representation of source pos stack" $
+      property (contains errorPos sourcePosPretty)
+    it "result contains representation of unexpected items" $
+      property (contains errorUnexpected showErrorComponent)
+    it "result contains representation of expected items" $
+      property (contains errorExpected showErrorComponent)
+    it "result contains representation of custom items" $
+      property (contains errorCustom showErrorComponent)
+
+  describe "sourcePosStackPretty" $
+    it "result never ends with a newline " $
+      property $ \x ->
+        let pos = errorPos (x :: PE)
+        in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)
+
+  describe "parseErrorTextPretty" $ do
+    it "shows unknown ParseError correctly" $
+      parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n"
+    it "result always ends with a newline" $
+      property $ \x ->
+        parseErrorTextPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)
+
+----------------------------------------------------------------------------
+-- Helpers
+
+checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property
+checkMergedItems f e1 e2 = f (e1 <> e2) === r
+  where r = case (compare `on` errorPos) e1 e2 of
+              LT -> f e2
+              EQ -> (E.union `on` f) e1 e2
+              GT -> f e1
+
+contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property
+contains g r e = property (all f (g e))
+  where rendered = parseErrorPretty e
+        f x = r x `isInfixOf` rendered

tests/Text/Megaparsec/ExprSpec.hs

@@ -1,5 +1,5 @@
 --
--- QuickCheck tests for Megaparsec's expression parsers.
+-- Tests for Megaparsec's expression parsers.
 --
 -- Copyright © 2015–2016 Megaparsec contributors
 --
@@ -30,32 +30,54 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies     #-}
 
-module Expr (tests) where
+module Text.Megaparsec.ExprSpec (spec) where
 
 import Control.Applicative (some, (<|>))
-import Data.Char (isDigit, digitToInt)
+import Data.Monoid ((<>))
-
+import Test.Hspec
-import Test.Framework
+import Test.Hspec.Megaparsec
-import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Hspec.Megaparsec.AdHoc
 import Test.QuickCheck
-
 import Text.Megaparsec.Char
 import Text.Megaparsec.Combinator
 import Text.Megaparsec.Expr
 import Text.Megaparsec.Prim
 
-import Util
-
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)
 #endif
 
-tests :: Test
+spec :: Spec
-tests = testGroup "Expression parsers"
+spec =
-  [ testProperty "correctness of expression parser" prop_correctness
+  describe "makeExprParser" $ do
-  , testProperty "error message on empty input"     prop_empty_error
+    context "when given valid rendered AST" $
-  , testProperty "error message on missing term"    prop_missing_term
+      it "can parse it back" $
-  , testProperty "error message on missing op"      prop_missing_op ]
+        property $ \node -> do
+          let s = showNode node
+          prs  expr s `shouldParse`     node
+          prs' expr s `succeedsLeaving` ""
+    context "when stream in empty" $
+      it "signals correct parse error" $
+        prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term")
+    context "when term is missing" $
+      it "signals correct parse error" $ do
+        let p = expr <* eof
+            n = 1 :: Integer
+        prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term")
+        prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term")
+        prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term")
+    context "operator is missing" $
+      it "signals correct parse error" $
+        property $ \a b -> do
+          let p = expr <* eof
+              a' = inParens a
+              n  = length a' + 1
+              s  = a'  ++ " " ++ inParens b
+              c  = s !! n
+          if c == '-'
+            then prs p s `shouldParse` Sub a b
+            else prs p s `shouldFailWith`
+                 err (posN n s) (utok c <> eeof <> elabel "operator")
 
 -- Algebraic structures to build abstract syntax tree of our expression.
 
@@ -143,7 +165,7 @@ parens = between (symbol "(") (symbol ")")
 integer :: (MonadParsec e s m, Token s ~ Char) => m Integer
 integer = lexeme (read <$> some digitChar <?> "integer")
 
--- Here we use table of operators that makes use of all features of
+-- 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.
@@ -163,27 +185,3 @@ table = [ [ Prefix  (symbol "-" *> pure Neg)
           , InfixL  (symbol "/" *> pure Div) ]
         , [ InfixL  (symbol "+" *> pure Sum)
           , InfixL  (symbol "-" *> pure Sub)] ]
-
-prop_correctness :: Node -> Property
-prop_correctness node = checkParser expr (Right node) (showNode node)
-
-prop_empty_error :: Property
-prop_empty_error = checkParser expr r s
-  where r = posErr 0 s [ueof, elabel "term"]
-        s = ""
-
-prop_missing_term :: Char -> Property
-prop_missing_term c = checkParser expr r s
-  where r | c `elem` "-(" = posErr 1 s [ueof, elabel "term"]
-          | isDigit c     = Right . Val . fromIntegral . digitToInt $ c
-          | otherwise     = posErr 0 s [utok c, elabel "term"]
-        s = pure c
-
-prop_missing_op :: Node -> Node -> Property
-prop_missing_op a b = checkParser expr r s
-  where a' = inParens a
-        c = s !! n
-        n = succ $ length a'
-        r | c == '-'  = Right $ Sub a b
-          | otherwise = posErr n s [utok c, eeof, elabel "operator"]
-        s = a' ++ " " ++ inParens b

tests/Text/Megaparsec/LexerSpec.hs

@@ -0,0 +1,480 @@
+--
+-- Tests for Megaparsec's lexer.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE CPP              #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf       #-}
+{-# LANGUAGE TupleSections    #-}
+{-# LANGUAGE TypeFamilies     #-}
+
+module Text.Megaparsec.LexerSpec (spec) where
+
+import Control.Applicative
+import Control.Monad (void)
+import Data.Char hiding (ord)
+import Data.List (isInfixOf)
+import Data.Maybe
+import Data.Monoid ((<>))
+import Data.Scientific (fromFloatDigits)
+import Numeric (showInt, showHex, showOct)
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Test.Hspec.Megaparsec.AdHoc
+import Test.QuickCheck
+import Text.Megaparsec.Error
+import Text.Megaparsec.Lexer
+import Text.Megaparsec.Pos
+import Text.Megaparsec.Prim
+import Text.Megaparsec.String
+import qualified Text.Megaparsec.Char as C
+
+spec :: Spec
+spec = do
+
+  describe "space" $
+    it "consumes any sort of white space" $
+      property $ forAll mkWhiteSpace $ \s -> do
+        prs  scn s `shouldParse` ()
+        prs' scn s `succeedsLeaving` ""
+
+  describe "symbol" $
+    context "when stream begins with the symbol" $
+      it "parses the symbol and trailing whitespace" $
+        property $ forAll mkSymbol $ \s -> do
+          let p = symbol scn y
+              y = takeWhile (not . isSpace) s
+          prs  p s `shouldParse` y
+          prs' p s `succeedsLeaving` ""
+
+  describe "symbol'" $
+    context "when stream begins with the symbol" $
+      it "parses the symbol and trailing whitespace" $
+        property $ forAll mkSymbol $ \s -> do
+          let p = symbol' scn (toUpper <$> y)
+              y = takeWhile (not . isSpace) s
+          prs  p s `shouldParse` y
+          prs' p s `succeedsLeaving` ""
+
+  describe "skipLineComment" $
+    context "when there is no newline at the end of line" $
+      it "is picked up successfully" $ do
+        let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof
+            s = "  // this line comment doesn't have a newline at the end "
+        prs  p s `shouldParse` ()
+        prs' p s `succeedsLeaving` ""
+
+  describe "skipBlockCommentNested" $
+    context "when it runs into nested block comments" $
+      it "parses them all right" $ do
+        let p = space (void C.spaceChar) empty
+              (skipBlockCommentNested "/*" "*/") <* eof
+            s = " /* foo bar /* baz */ quux */ "
+        prs  p s `shouldParse` ()
+        prs' p s `succeedsLeaving` ""
+
+  describe "indentLevel" $
+    it "returns current indentation level (column)" $
+      property $ \pos -> do
+        let p = setPosition pos *> indentLevel
+        prs p "" `shouldParse` sourceColumn pos
+
+  describe "incorrectIndent" $
+    it "signals correct parse error" $
+      property $ \ord ref actual -> do
+        let p :: Parser ()
+            p = incorrectIndent ord ref actual
+        prs p "" `shouldFailWith` err posI (ii ord ref actual)
+
+  describe "indentGuard" $
+    it "works as intended" $
+      property $ \n -> do
+        let mki = mkIndent sbla (getSmall $ getNonNegative n)
+        forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do
+          let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
+              fragments = [l0,l1,l2]
+              g x = sum (length <$> take x fragments)
+              s = concat fragments
+              p  = ip GT pos1 >>=
+                \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn
+              ip = indentGuard scn
+              sp = void (symbol sc sbla <* C.eol)
+          if | col0 <= pos1 ->
+               prs p s `shouldFailWith` err posI (ii GT pos1 col0)
+             | col1 /= col0 ->
+               prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)
+             | col2 <= col0 ->
+               prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)
+             | otherwise    ->
+               prs p s `shouldParse` ()
+
+  describe "nonIdented" $
+    it "works as intended" $
+      property $ forAll (mkIndent sbla 0) $ \s -> do
+        let p = nonIndented scn (symbol scn sbla)
+            i = getIndent s
+        if i == 0
+          then prs p s `shouldParse` sbla
+          else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s))
+
+  describe "indentBlock" $ do
+    it "works as indented" $
+      property $ \mn'' -> do
+        let mkBlock = do
+              l0 <- mkIndent sbla 0
+              l1 <- mkIndent sblb ib
+              l2 <- mkIndent sblc (ib + 2)
+              l3 <- mkIndent sblb ib
+              l4 <- mkIndent' sblc (ib + 2)
+              return (l0,l1,l2,l3,l4)
+            ib  = fromMaybe 2 mn'
+            mn' = getSmall . getPositive <$> mn''
+            mn  = unsafePos . fromIntegral <$> mn'
+        forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do
+          let (col0, col1, col2, col3, col4) =
+                (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)
+              fragments = [l0,l1,l2,l3,l4]
+              g x = sum (length <$> take x fragments)
+              s = concat fragments
+              p = lvla <* eof
+              lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla
+              lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb
+              lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc
+              b    = symbol sc
+              l x  = return . (x,)
+              ib'  = unsafePos (fromIntegral ib)
+          if | col1 <= col0 -> prs p s `shouldFailWith`
+               err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof)
+             | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`
+               err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)
+             | col2 <= col1 -> prs p s `shouldFailWith`
+               err (posN (getIndent l2 + g 2) s) (ii GT col1 col2)
+             | col3 == col2 -> prs p s `shouldFailWith`
+               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc)
+             | col3 <= col0 -> prs p s `shouldFailWith`
+               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof)
+             | col3 < col1 -> prs p s `shouldFailWith`
+               err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)
+             | col3 > col1 -> prs p s `shouldFailWith`
+               err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)
+             | col4 <= col3 -> prs p s `shouldFailWith`
+               err (posN (getIndent l4 + g 4) s) (ii GT col3 col4)
+             | otherwise -> prs p s `shouldParse`
+               (sbla, [(sblb, [sblc]), (sblb, [sblc])])
+    it "IndentMany works as intended" $
+      property $ forAll (mkIndent sbla 0) $ \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` ""
+
+  describe "lineFold" $
+    it "works as intended" $
+      property $ do
+        let mkFold = do
+              l0 <- mkInterspace sbla 0
+              l1 <- mkInterspace sblb 1
+              l2 <- mkInterspace sblc 1
+              return (l0,l1,l2)
+        forAll mkFold $ \(l0,l1,l2) -> do
+          let p = lineFold scn $ \sc' -> do
+                a <- symbol sc' sbla
+                b <- symbol sc' sblb
+                c <- symbol scn sblc
+                return (a, b, c)
+              getEnd x = last x == '\n'
+              fragments = [l0,l1,l2]
+              g x = sum (length <$> take x fragments)
+              s = concat fragments
+              (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
+              (end0, end1)       = (getEnd l0, getEnd l1)
+          if | end0 && col1 <= col0 -> prs p s `shouldFailWith`
+               err (posN (getIndent l1 + g 1) s) (ii GT col0 col1)
+             | end1 && col2 <= col0 -> prs p s `shouldFailWith`
+               err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)
+             | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)
+
+  describe "charLiteral" $ do
+    context "when stream begins with a literal character" $
+      it "parses it" $
+        property $ \ch -> do
+          let p = charLiteral
+              s = showLitChar ch ""
+          prs  p s `shouldParse` ch
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with a literal character" $
+      it "signals correct parse error" $ do
+        let p = charLiteral
+            s = "\\"
+        prs  p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character")
+        prs' p s `failsLeaving` s
+    context "when stream is empty" $
+      it "signals correct parse error" $ do
+        let p = charLiteral
+        prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character")
+
+  describe "integer" $ do
+    context "when stream begins with decimal digits" $
+      it "they are parsed as an integer" $
+        property $ \n' -> do
+          let p = integer
+              n = getNonNegative n'
+              s = showInt n ""
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with decimal digits" $
+      it "signals correct parse error" $
+        property $ \a as -> not (isDigit a) ==> do
+          let p = integer
+              s = a : as
+          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs integer "" `shouldFailWith`
+          err posI (ueof <> elabel "integer")
+
+  describe "decimal" $ do
+    context "when stream begins with decimal digits" $
+      it "they are parsed as an integer" $
+        property $ \n' -> do
+          let p = decimal
+              n = getNonNegative n'
+              s = showInt n ""
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with decimal digits" $
+      it "signals correct parse error" $
+        property $ \a as -> not (isDigit a) ==> do
+          let p = decimal
+              s = a : as
+          prs  p s `shouldFailWith` err posI (utok a <> elabel "decimal integer")
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs decimal "" `shouldFailWith`
+          err posI (ueof <> elabel "decimal integer")
+
+  describe "hexadecimal" $ do
+    context "when stream begins with hexadecimal digits" $
+      it "they are parsed as an integer" $
+        property $ \n' -> do
+          let p = hexadecimal
+              n = getNonNegative n'
+              s = showHex n ""
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with hexadecimal digits" $
+      it "signals correct parse error" $
+        property $ \a as -> not (isHexDigit a) ==> do
+          let p = hexadecimal
+              s = a : as
+          prs  p s `shouldFailWith`
+            err posI (utok a <> elabel "hexadecimal integer")
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs hexadecimal "" `shouldFailWith`
+          err posI (ueof <> elabel "hexadecimal integer")
+
+  describe "octal" $ do
+    context "when stream begins with octal digits" $
+      it "they are parsed as an integer" $
+        property $ \n' -> do
+          let p = octal
+              n = getNonNegative n'
+              s = showOct n ""
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with octal digits" $
+      it "signals correct parse error" $
+        property $ \a as -> not (isOctDigit a) ==> do
+          let p = octal
+              s = a : as
+          prs  p s `shouldFailWith`
+            err posI (utok a <> elabel "octal integer")
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs octal "" `shouldFailWith`
+          err posI (ueof <> elabel "octal integer")
+
+  describe "float" $ do
+    context "when stream begins with a float" $
+      it "parses it" $
+        property $ \n' -> do
+          let p = float
+              n = getNonNegative n'
+              s = show n
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when stream does not begin with a float" $
+      it "signals correct parse error" $
+        property $ \a as -> not (isDigit a) ==> do
+          let p = float
+              s = a : as
+          prs  p s `shouldFailWith`
+            err posI (utok a <> elabel "floating point number")
+          prs' p s `failsLeaving` s
+    context "when stream begins with a decimal number" $
+      it "signals correct parse error" $
+        property $ \n' -> do
+          let p = float
+              n = getNonNegative n'
+              s = show (n :: Integer)
+          prs  p s `shouldFailWith` err (posN (length s) s)
+            (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")
+          prs' p s `failsLeaving` ""
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs float "" `shouldFailWith`
+          err posI (ueof <> elabel "floating point number")
+
+  describe "number" $ do
+    context "when stream begins with a number" $
+      it "parses it" $
+        property $ \n' -> do
+          let p = number
+              s = either (show . getNonNegative) (show . getNonNegative)
+                (n' :: Either (NonNegative Integer) (NonNegative Double))
+          prs p s `shouldParse` case n' of
+            Left  x -> fromIntegral    (getNonNegative x)
+            Right x -> fromFloatDigits (getNonNegative x)
+          prs' p s `succeedsLeaving` ""
+    context "when stream is empty" $
+      it "signals correct parse error" $
+        prs number "" `shouldFailWith`
+          err posI (ueof <> elabel "number")
+
+  describe "signed" $ do
+    context "with integer" $
+      it "parses signed integers" $
+        property $ \n -> do
+          let p = signed (hidden C.space) integer
+              s = show n
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "with float" $
+      it "parses signed floats" $
+        property $ \n -> do
+          let p = signed (hidden C.space) float
+              s = show n
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "with number" $
+      it "parses singed numbers" $
+        property $ \n -> do
+          let p = signed (hidden C.space) number
+              s = either show show (n :: Either Integer Double)
+          prs p s `shouldParse` case n of
+            Left  x -> fromIntegral    x
+            Right x -> fromFloatDigits x
+    context "when number is prefixed with plus sign" $
+      it "parses the number" $
+        property $ \n' -> do
+          let p = signed (hidden C.space) integer
+              n = getNonNegative n'
+              s = show n
+          prs  p s `shouldParse` n
+          prs' p s `succeedsLeaving` ""
+    context "when number is prefixed with white space" $
+      it "signals correct parse error" $
+        property $ \n -> do
+          let p = signed (hidden C.space) integer
+              s = ' ' : show (n :: Integer)
+          prs  p s `shouldFailWith` err posI
+            (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")
+          prs' p s `failsLeaving` s
+    context "when there is white space between sign and digits" $
+      it "parses it all right" $ do
+        let p = signed (hidden C.space) integer
+            s = "- 123"
+        prs  p s `shouldParse` (-123)
+        prs' p s `succeedsLeaving` ""
+
+----------------------------------------------------------------------------
+-- Helpers
+
+mkWhiteSpace :: Gen String
+mkWhiteSpace = concat <$> listOf whiteUnit
+  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]
+
+mkSymbol :: Gen String
+mkSymbol = (++) <$> symbolName <*> whiteChars
+
+mkInterspace :: String -> Int -> Gen String
+mkInterspace x n = oneof [si, mkIndent x n]
+  where si = (++ x) <$> listOf (elements " \t")
+
+mkIndent :: String -> Int -> Gen String
+mkIndent x n = (++) <$> mkIndent' x n <*> eol
+  where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]
+
+mkIndent' :: String -> Int -> Gen String
+mkIndent' x n = concat <$> sequence [spc, sym, tra]
+  where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]
+        tra = listOf itm
+        itm = elements " \t"
+        sym = return x
+
+whiteChars :: Gen String
+whiteChars = listOf (elements "\t\n ")
+
+whiteLine :: Gen String
+whiteLine = commentOut <$> arbitrary `suchThat` goodEnough
+  where commentOut x = "//" ++ x ++ "\n"
+        goodEnough x = '\n' `notElem` x
+
+whiteBlock :: Gen String
+whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough
+  where commentOut x = "/*" ++ x ++ "*/"
+        goodEnough x = not $ "*/" `isInfixOf` x
+
+symbolName :: Gen String
+symbolName = listOf $ arbitrary `suchThat` isAlphaNum
+
+sc :: Parser ()
+sc = space (void $ C.oneOf " \t") empty empty
+
+scn :: Parser ()
+scn = space (void C.spaceChar) l b
+  where l = skipLineComment "//"
+        b = skipBlockComment "/*" "*/"
+
+getIndent :: String -> Int
+getIndent = length . takeWhile isSpace
+
+getCol :: String -> Pos
+getCol x = sourceColumn .
+  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x
+
+sbla, sblb, sblc :: String
+sbla = "aaa"
+sblb = "bbb"
+sblc = "ccc"
+
+ii :: Ordering -> Pos -> Pos -> EC Char Dec
+ii ord ref actual = cstm (DecIndentation ord ref actual)

tests/Text/Megaparsec/PermSpec.hs

@@ -0,0 +1,125 @@
+--
+-- Tests for Megaparsec's permutation phrases parsers.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE MultiWayIf #-}
+
+module Text.Megaparsec.PermSpec (spec) where
+
+import Control.Applicative
+import Data.List (nub, elemIndices)
+import Data.Monoid
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Test.Hspec.Megaparsec.AdHoc
+import Test.QuickCheck
+import Text.Megaparsec.Char
+import Text.Megaparsec.Lexer (integer)
+import Text.Megaparsec.Perm
+
+data CharRows = CharRows
+  { getChars :: (Char, Char, Char)
+  , getInput :: String }
+  deriving (Eq, Show)
+
+instance Arbitrary CharRows where
+  arbitrary = do
+    chars@(a,b,c) <- arbitrary `suchThat` different
+    an            <- arbitrary
+    bn            <- arbitrary
+    cn            <- arbitrary
+    input <- concat <$> shuffle
+             [ replicate an a
+             , replicate bn b
+             , replicate cn c]
+    return $ CharRows chars input
+      where different (a,b,c) = let l = [a,b,c] in l == nub l
+
+spec :: Spec
+spec = do
+
+  describe "(<$$>)" $ do
+    context "when supplied parser succeeds" $
+      it "returns value returned by the parser" $
+        property $ \n -> do
+          let p = makePermParser (succ <$$> pure (n :: Integer))
+          prs p "" `shouldParse` succ n
+    context "when supplied parser fails" $
+      it "signals correct parse error" $ do
+          let p = makePermParser (succ <$$> integer)
+          prs p "" `shouldFailWith` err posI (ueof <> elabel "integer")
+
+  describe "(<$?>)" $ do
+    context "when supplied parser succeeds" $
+      it "returns value returned by the parser" $
+        property $ \n m -> do
+          let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer)))
+          prs p "" `shouldParse` succ m
+    context "when supplied parser fails" $
+      it "returns the default value" $
+        property $ \n -> do
+          let p = makePermParser (succ <$?> (n :: Integer, fail "foo"))
+          prs p "" `shouldParse` succ n
+    context "when stream in empty" $
+      it "returns the default value" $
+        property $ \n -> do
+          let p = makePermParser (succ <$?> (n :: Integer, integer))
+          prs p "" `shouldParse` succ n
+
+  describe "makeExprParser" $
+    it "works" $
+      property $ \a' c' v -> do
+        let (a,b,c) = getChars v
+            p = makePermParser
+              ((,,) <$?> (a' :: String, some (char a))
+                <||> char b
+                <|?> (c', char c))
+            bis  = elemIndices b s
+            preb = take (bis !! 1) s
+            cis  = elemIndices c s
+            prec = take (cis !! 1) s
+            s    = getInput v
+        if | length bis > 1 && (length cis <= 1 || head bis < head cis) ->
+               prs_ p s `shouldFailWith` err (posN (bis !! 1) s)
+                 ( utok b <> eeof <>
+                   (if a `elem` preb then mempty else etok a) <>
+                   (if c `elem` preb then mempty else etok c) )
+           | length cis > 1 ->
+               prs_ p s `shouldFailWith` err (posN (cis !! 1) s)
+                 ( utok c <>
+                   (if a `elem` prec then mempty else etok a) <>
+                   (if b `elem` prec then eeof   else etok b) )
+           | b `notElem` s ->
+               prs_ p s `shouldFailWith` err (posN (length s) s)
+                 ( ueof <> etok b <>
+                   (if a `notElem` s || last s == a then etok a else mempty) <>
+                   (if c `elem` s then mempty else etok c) )
+           | otherwise ->
+               prs_ p s `shouldParse`
+                 ( if a `elem` s then filter (== a) s else a'
+                 , b
+                 , if c `elem` s then c else c' )

tests/Text/Megaparsec/PosSpec.hs

@@ -0,0 +1,127 @@
+--
+-- Tests for Megaparsec's textual source positions.
+--
+-- Copyright © 2015–2016 Megaparsec contributors
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- * Redistributions of source code must retain the above copyright notice,
+--   this list of conditions and the following disclaimer.
+--
+-- * Redistributions in binary form must reproduce the above copyright
+--   notice, this list of conditions and the following disclaimer in the
+--   documentation and/or other materials provided with the distribution.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+-- POSSIBILITY OF SUCH DAMAGE.
+
+{-# LANGUAGE CPP              #-}
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Text.Megaparsec.PosSpec (spec) where
+
+import Data.Function (on)
+import Data.List (isInfixOf)
+import Data.Semigroup ((<>))
+import Test.Hspec
+import Test.Hspec.Megaparsec.AdHoc
+import Test.QuickCheck
+import Text.Megaparsec.Pos
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Word (Word)
+#endif
+
+spec :: Spec
+spec = do
+
+  describe "mkPos" $ do
+    context "when the argument is 0" $
+      it "throws InvalidPosException" $
+        mkPos (0 :: Word) `shouldThrow` (== InvalidPosException)
+    context "when the argument is not 0" $
+      it "returns Pos with the given value" $
+        property $ \n ->
+          (n > 0) ==> (mkPos n >>= shouldBe n . unPos)
+
+  describe "unsafePos" $
+    context "when the argument is a positive integer" $
+      it "returns Pos with the given value" $
+        property $ \n ->
+          (n > 0) ==> (unPos (unsafePos n) === n)
+
+  describe "Read and Show instances of Pos" $
+    it "printed representation of Pos is isomorphic to its value" $
+      property $ \x ->
+        read (show x) === (x :: Pos)
+
+  describe "Ord instance of Pos" $
+    it "works just like Ord instance of underlying Word" $
+      property $ \x y ->
+        compare x y === (compare `on` unPos) x y
+
+  describe "Semigroup instance of Pos" $
+    it "works like addition" $
+      property $ \x y ->
+        x <> y === unsafePos (unPos x + unPos y) .&&.
+        unPos (x <> y) === unPos x + unPos y
+
+  describe "initialPos" $
+    it "consturcts initial position correctly" $
+      property $ \path ->
+        let x = initialPos path
+        in sourceName   x === path        .&&.
+           sourceLine   x === unsafePos 1 .&&.
+           sourceColumn x === unsafePos 1
+
+  describe "Read and Show instances of SourcePos" $
+    it "printed representation of SourcePos in isomorphic to its value" $
+      property $ \x ->
+        read (show x) === (x :: SourcePos)
+
+  describe "sourcePosPretty" $ do
+    it "displays file name" $
+      property $ \x ->
+        sourceName x `isInfixOf` sourcePosPretty x
+    it "displays line number" $
+      property $ \x ->
+        (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x
+    it "displays column number" $
+      property $ \x ->
+        (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x
+
+  describe "defaultUpdatePos" $ do
+    it "returns actual position unchanged" $
+      property $ \w pos ch ->
+        fst (defaultUpdatePos w pos ch) === pos
+    it "does not change file name" $
+      property $ \w pos ch ->
+        (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos
+    context "when given newline character" $
+      it "increments line number" $
+        property $ \w pos ->
+          (sourceLine . snd) (defaultUpdatePos w pos '\n')
+            === (sourceLine pos <> pos1)
+    context "when given tab character" $
+      it "shits column number to next tab position" $
+        property $ \w pos ->
+          let c  = sourceColumn pos
+              c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t')
+          in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0)
+    context "when given character other than newline or tab" $
+      it "increments column number by one" $
+        property $ \w pos ch ->
+          (ch /= '\n' && ch /= '\t') ==>
+          (sourceColumn . snd) (defaultUpdatePos w pos ch)
+            === (sourceColumn pos <> pos1)

tests/Util.hs

@@ -1,369 +0,0 @@
---
--- QuickCheck tests for Megaparsec, utility functions for parser testing.
---
--- Copyright © 2015–2016 Megaparsec contributors
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- * Redistributions of source code must retain the above copyright notice,
---   this list of conditions and the following disclaimer.
---
--- * Redistributions in binary form must reproduce the above copyright
---   notice, this list of conditions and the following disclaimer in the
---   documentation and/or other materials provided with the distribution.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--- POSSIBILITY OF SUCH DAMAGE.
-
-{-# LANGUAGE CPP              #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes       #-}
-{-# OPTIONS -fno-warn-orphans #-}
-
-module Util
-  ( checkParser
-  , checkParser'
-  , checkCase
-  , checkCase'
-  , simpleParse
-  , checkChar
-  , checkString
-  , updatePosString
-  , (/=\)
-  , (!=!)
-  , abcRow
-  , EC (..)
-  , posErr
-  , posErr'
-  , utok
-  , utoks
-  , ulabel
-  , ueof
-  , etok
-  , etoks
-  , elabel
-  , eeof
-  , cstm )
-where
-
-import Control.Monad.Reader
-import Control.Monad.Trans.Identity
-import Data.Foldable (foldl')
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.Maybe (mapMaybe, maybeToList)
-import qualified Control.Monad.State.Lazy    as L
-import qualified Control.Monad.State.Strict  as S
-import qualified Control.Monad.Writer.Lazy   as L
-import qualified Control.Monad.Writer.Strict as S
-import qualified Data.List.NonEmpty          as NE
-import qualified Data.Set                    as E
-
-import Test.QuickCheck
-import Test.HUnit (Assertion, (@?=))
-
-import Text.Megaparsec.Error
-import Text.Megaparsec.Pos
-import Text.Megaparsec.Prim
-import Text.Megaparsec.String
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*>), (<*))
-#endif
-
--- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse
--- entire @s@. Result of the parsing is compared with expected result @r@,
--- it should match, otherwise the property doesn't hold and the test fails.
-
-checkParser :: (Eq a, Show a)
-  => Parser a          -- ^ Parser to test
-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing
-  -> String            -- ^ Input for the parser
-  -> Property          -- ^ Resulting property
-checkParser p r s = simpleParse p s === r
-
--- | A variant of 'checkParser' that runs given parser code with all
--- standard instances of 'MonadParsec'. Useful when testing primitive
--- combinators.
-
-checkParser' :: (Eq a, Show a)
-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test
-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing
-  -> String            -- ^ Input for the parser
-  -> Property          -- ^ Resulting property
-checkParser' p r s = conjoin
-  [ checkParser p                   r s
-  , checkParser (runIdentityT p)    r s
-  , checkParser (runReaderT   p ()) r s
-  , checkParser (L.evalStateT p ()) r s
-  , checkParser (S.evalStateT p ()) r s
-  , checkParser (evalWriterTL p)    r s
-  , checkParser (evalWriterTS p)    r s ]
-
--- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.
-
-checkCase :: (Eq a, Show a)
-  => Parser a          -- ^ Parser to test
-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing
-  -> String            -- ^ Input for the parser
-  -> Assertion         -- ^ Resulting assertion
-checkCase p r s = simpleParse p s @?= r
-
--- | Similar to 'checkParser'', but produces HUnit's 'Assertion's instead.
-
-checkCase' :: (Eq a, Show a)
-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test
-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing
-  -> String            -- ^ Input for the parser
-  -> Assertion         -- ^ Resulting assertion
-checkCase' p r s = do
-  parse p                   "" s @?= r
-  parse (runIdentityT p)    "" s @?= r
-  parse (runReaderT   p ()) "" s @?= r
-  parse (L.evalStateT p ()) "" s @?= r
-  parse (S.evalStateT p ()) "" s @?= r
-  parse (evalWriterTL p)    "" s @?= r
-  parse (evalWriterTS p)    "" s @?= r
-
-evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
-evalWriterTL = liftM fst . L.runWriterT
-evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
-evalWriterTS = liftM fst . S.runWriterT
-
--- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding
--- result of type @Either ParseError a@, where @a@ is type of parsed
--- value. This parser tries to parser end of file too and name of input file
--- is always empty string.
-
-simpleParse :: Parser a -> String -> Either (ParseError Char Dec) a
-simpleParse p = parse (p <* eof) ""
-
--- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if
--- the parser correctly parses single character that satisfies @test@. The
--- character may be labelled, in this case @label@ is used to check quality
--- of error messages.
-
-checkChar
-  :: Parser Char       -- ^ Parser to run
-  -> (Char -> Bool)    -- ^ Predicate to test parsed char
-  -> Maybe (ErrorItem Char) -- ^ Representation to use in error messages
-  -> String            -- ^ Input stream
-  -> Property          -- ^ Resulting property
-checkChar p f rep' s = checkParser p r s
-  where h = head s
-        rep = Expected <$> maybeToList rep'
-        r | null s = posErr 0 s (ueof : rep)
-          | length s == 1 && f h = Right h
-          | not (f h) = posErr 0 s (utok h : rep)
-          | otherwise = posErr 1 s [utok (s !! 1), eeof]
-
--- | @checkString p a test label s@ runs parser @p@ on input @s@ and checks if
--- the result is equal to @a@ and also quality of error messages. @test@ is
--- used to compare tokens. @label@ is used as expected representation of
--- parser's result in error messages.
-
-checkString
-  :: Parser String     -- ^ Parser to run
-  -> String            -- ^ Expected result
-  -> (Char -> Char -> Bool) -- ^ Function used to compare tokens
-  -> String            -- ^ Input stream
-  -> Property
-checkString p a' test s' = checkParser p (w a' 0 s') s'
-  where w [] _ []    = Right s'
-        w [] i (s:_) = posErr i s' [utok s, eeof]
-        w _  0 []    = posErr 0 s' [ueof, etoks a']
-        w _  i []    = posErr 0 s' [utoks (take i s'), etoks a']
-        w (a:as) i (s:ss)
-          | test a s  = w as i' ss
-          | otherwise = posErr 0 s' [utoks (take i' s'), etoks a']
-            where i'  = succ i
-
--- | A helper function that is used to advance 'SourcePos' given a 'String'.
-
-updatePosString
-  :: Pos               -- ^ Tab width
-  -> SourcePos         -- ^ Initial position
-  -> String            -- ^ 'String' — collection of tokens to process
-  -> SourcePos         -- ^ Final position
-updatePosString w = foldl' f
-  where f p t = snd (defaultUpdatePos w p t)
-
-infix 4 /=\   -- preserve whitespace on automatic trim
-
--- | @p /=\\ x@ runs parser @p@ on empty input and compares its result
--- (which should be successful) with @x@. Succeeds when the result is equal
--- to @x@, prints counterexample on failure.
-
-(/=\) :: (Eq a, Show a) => Parser a -> a -> Property
-p /=\ x = simpleParse p "" === Right x
-
-infix 4 !=!
-
--- | @n !=! m@ represents property that holds when results of running @n@
--- and @m@ parsers are identical. This is useful when checking monad laws
--- for example.
-
-(!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property
-n !=! m = simpleParse n "" === simpleParse m ""
-
--- | @abcRow a b c@ generates string consisting of character “a” repeated
--- @a@ times, character “b” repeated @b@ times, and finally character “c”
--- repeated @c@ times.
-
-abcRow :: Enum a => a -> a -> a -> String
-abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'
-  where f x = replicate (fromEnum x)
-
--- | A component of parse error, useful for fast and dirty construction of
--- parse errors with 'posErr' and other helpers.
-
-data EC
-  = Unexpected (ErrorItem Char)
-  | Expected   (ErrorItem Char)
-  | Custom     Dec
-
-#if !MIN_VERSION_QuickCheck(2,9,0)
-instance Arbitrary a => Arbitrary (NonEmpty a) where
-  arbitrary = NE.fromList . getNonEmpty <$> arbitrary
-#endif
-
-instance Arbitrary t => Arbitrary (ErrorItem t) where
-  arbitrary = oneof
-    [ Tokens <$> arbitrary
-    , Label  <$> arbitrary
-    , return EndOfInput ]
-
-instance Arbitrary Pos where
-  arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))
-
-instance Arbitrary SourcePos where
-  arbitrary = SourcePos
-    <$> shortString
-    <*> (unsafePos <$> choose (1, 1000))
-    <*> (unsafePos <$> choose (1,  100))
-
-instance Arbitrary Dec where
-  arbitrary = oneof
-    [ DecFail        <$> shortString
-    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]
-
-instance (Arbitrary t, Ord t, Arbitrary e, Ord e)
-    => Arbitrary (ParseError t e) where
-  arbitrary = ParseError
-    <$> arbitrary
-    <*> arbitrary
-    <*> arbitrary
-    <*> arbitrary
-
-shortString :: Gen String
-shortString = sized $ \n -> do
-  k <- choose (0, n `div` 2)
-  vectorOf k arbitrary
-
--- | @posErr pos s ms@ is an easy way to model result of parser that fails.
--- @pos@ is how many tokens (characters) has been consumed before failure.
--- @s@ is input of the parser. @ms@ is a list, collection of 'Message's. See
--- 'utok', 'utoks', 'ulabel', 'ueof', 'etok', 'etoks', 'elabel', and 'eeof'
--- for easy ways to create error messages.
-
-posErr
-  :: Int               -- ^ How many tokens to drop from beginning of steam
-  -> String            -- ^ The input stream (just a 'String' here)
-  -> [EC]              -- ^ Collection of error components
-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'
-posErr i s = posErr' (pos :| [])
-  where pos = updatePosString defaultTabWidth (initialPos "") (take i s)
-
--- | The same as 'posErr', but 'SourcePos' should be provided directly.
-
-posErr'
-  :: NonEmpty SourcePos -- ^ Position of the error
-  -> [EC]              -- ^ Collection of error components
-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'
-posErr' pos ecs = Left ParseError
-  { errorPos        = pos
-  , errorUnexpected = E.fromList (mapMaybe getUnexpected ecs)
-  , errorExpected   = E.fromList (mapMaybe getExpected   ecs)
-  , errorCustom     = E.fromList (mapMaybe getCustom     ecs) }
-  where
-    getUnexpected (Unexpected x) = Just x
-    getUnexpected _              = Nothing
-    getExpected   (Expected   x) = Just x
-    getExpected   _              = Nothing
-    getCustom     (Custom     x) = Just x
-    getCustom     _              = Nothing
-
--- | Construct “unexpected token” error component.
-
-utok :: Char -> EC
-utok = Unexpected . Tokens . nes
-
--- | Construct “unexpected steam” error component. This function respects
--- some conventions described in 'canonicalizeStream'.
-
-utoks :: String -> EC
-utoks = Unexpected . canonicalizeStream
-
--- | Construct “unexpected label” error component. Do not use with empty
--- strings.
-
-ulabel :: String -> EC
-ulabel = Unexpected . Label . NE.fromList
-
--- | Construct “unexpected end of input” error component.
-
-ueof :: EC
-ueof = Unexpected EndOfInput
-
--- | Construct “expecting token” error component.
-
-etok :: Char -> EC
-etok = Expected . Tokens . nes
-
--- | Construct “expecting stream” error component. This function respects
--- some conventions described in 'canonicalizeStream'.
-
-etoks :: String -> EC
-etoks = Expected . canonicalizeStream
-
--- | Construct “expecting label” error component. Do not use with empty
--- strings.
-
-elabel :: String -> EC
-elabel = Expected . Label . NE.fromList
-
--- | Construct “expecting end of input” component.
-
-eeof :: EC
-eeof = Expected EndOfInput
-
--- | Construct error component consisting of custom data.
-
-cstm :: Dec -> EC
-cstm = Custom
-
--- | Construct appropriate 'MessageItem' representation for given token
--- stream. Empty string produces 'EndOfInput', single token — a 'Token', and
--- in other cases the 'TokenStream' constructor is used.
-
-canonicalizeStream :: String -> ErrorItem Char
-canonicalizeStream stream =
-  case NE.nonEmpty stream of
-    Nothing      -> EndOfInput
-    Just xs      -> Tokens xs
-
--- | Make a singleton non-empty list from a value.
-
-nes :: a -> NonEmpty a
-nes x = x :| []
-{-# INLINE nes #-}