diff --git a/.travis.yml b/.travis.yml index 64c8c26..02b6a75 100644 --- a/.travis.yml +++ b/.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 - - cabal test --show-details=always - --test-option=--threads=2 - --test-option=--maximum-generated-tests=1000 + - travis_wait 60 cabal build + - case "$GHCVER" in + "7.6.3") true ;; + *) 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"; diff --git a/CHANGELOG.md b/CHANGELOG.md index fb5f922..1a2742c 100644 --- a/CHANGELOG.md +++ b/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`, diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs index 559f7e2..36f25a8 100644 --- a/Text/Megaparsec/Char.hs +++ b/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'. diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs index 2048d16..1635bf5 100644 --- a/Text/Megaparsec/Error.hs +++ b/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 '\a' = "bell" -charPretty '\b' = "backspace" -charPretty '\t' = "tab" -charPretty '\n' = "newline" -charPretty '\v' = "vertical tab" -charPretty '\f' = "form feed" -charPretty '\r' = "carriage return" -charPretty ' ' = "space" +charPretty '\NUL' = "null (control character)" +charPretty '\SOH' = "start of heading (control character)" +charPretty '\STX' = "start of text (control character)" +charPretty '\ETX' = "end of text (control character)" +charPretty '\EOT' = "end of transmission (control character)" +charPretty '\ENQ' = "enquiry (control character)" +charPretty '\ACK' = "acknowledge (control character)" +charPretty '\BEL' = "bell (control character)" +charPretty '\BS' = "backspace" +charPretty '\t' = "tab" +charPretty '\n' = "newline" +charPretty '\v' = "vertical tab" +charPretty '\f' = "form feed (control character)" +charPretty '\r' = "carriage return" +charPretty '\SO' = "shift out (control character)" +charPretty '\SI' = "shift in (control character)" +charPretty '\DLE' = "data link escape (control character)" +charPretty '\DC1' = "device control one (control character)" +charPretty '\DC2' = "device control two (control character)" +charPretty '\DC3' = "device control three (control character)" +charPretty '\DC4' = "device control four (control character)" +charPretty '\NAK' = "negative acknowledge (control character)" +charPretty '\SYN' = "synchronous idle (control character)" +charPretty '\ETB' = "end of transmission block (control character)" +charPretty '\CAN' = "cancel (control character)" +charPretty '\EM' = "end of medium (control character)" +charPretty '\SUB' = "substitute (control character)" +charPretty '\ESC' = "escape (control character)" +charPretty '\FS' = "file separator (control character)" +charPretty '\GS' = "group separator (control character)" +charPretty '\RS' = "record separator (control character)" +charPretty '\US' = "unit separator (control character)" +charPretty '\DEL' = "delete (control character)" +charPretty ' ' = "space" +charPretty '\160' = "non-breaking space" charPretty x = "'" ++ [x] ++ "'" -- | The type class defines how to print custom data component of diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs index 4a6506d..5c6fca3 100644 --- a/Text/Megaparsec/Pos.hs +++ b/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. -- diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs index b4a85fe..20a23dc 100644 --- a/Text/Megaparsec/Prim.hs +++ b/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. diff --git a/megaparsec.cabal b/megaparsec.cabal index 829c6ce..9d832a6 100644 --- a/megaparsec.cabal +++ b/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 - , Combinator - , Error - , Expr - , Lexer - , Perm - , Pos - , Prim - , Util - build-depends: base >= 4.6 && < 5.0 - , HUnit >= 1.2 && < 1.4 - , QuickCheck >= 2.8.2 && < 3.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.6 - , exceptions >= 0.6 && < 0.9 - , megaparsec >= 5.0.1 - , mtl >= 2.0 && < 3.0 - , scientific >= 0.3.1 && < 0.4 - , test-framework >= 0.6 && < 1.0 - , test-framework-hunit >= 0.3 && < 0.4 - , test-framework-quickcheck2 >= 0.3 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 + other-modules: Test.Hspec.Megaparsec + , Test.Hspec.Megaparsec.AdHoc + , Text.Megaparsec.CharSpec + , Text.Megaparsec.CombinatorSpec + , Text.Megaparsec.ErrorSpec + , Text.Megaparsec.ExprSpec + , Text.Megaparsec.LexerSpec + , Text.Megaparsec.PermSpec + , Text.Megaparsec.PosSpec + , Text.Megaparsec.PrimSpec + build-depends: QuickCheck >= 2.7 && < 3.0 + , base >= 4.6 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.6 && < 0.9 + , hspec >= 2.0 && < 3.0 + , hspec-expectations >= 0.5 && < 0.8 + , megaparsec >= 5.0.1 + , mtl >= 2.0 && < 3.0 + , scientific >= 0.3.1 && < 0.4 + , text >= 0.2 && < 1.3 + , 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 - , bytestring >= 0.10 && < 0.11 - , criterion >= 0.6.2.1 && < 1.2 - , megaparsec >= 5.0.1 - , text >= 0.2 && < 1.3 + build-depends: base >= 4.6 && < 5.0 + , bytestring >= 0.10 && < 0.11 + , criterion >= 0.6.2.1 && < 1.2 + , megaparsec >= 5.0.1 + , text >= 0.2 && < 1.3 default-language: Haskell2010 source-repository head diff --git a/megaparsec.ebal b/megaparsec.ebal index 6a7d399..ca65af5 100644 --- a/megaparsec.ebal +++ b/megaparsec.ebal @@ -1 +1 @@ -((test "--test-arguments=--threads=2 --maximum-generated-tests=1000")) +((test "--test-arguments=--qc-max-success=1000")) diff --git a/old-tests/Bugs.hs b/old-tests/Bugs.hs deleted file mode 100644 index ceae15d..0000000 --- a/old-tests/Bugs.hs +++ /dev/null @@ -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 ] diff --git a/old-tests/Bugs/Bug2.hs b/old-tests/Bugs/Bug2.hs deleted file mode 100644 index 04041dd..0000000 --- a/old-tests/Bugs/Bug2.hs +++ /dev/null @@ -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 diff --git a/old-tests/Bugs/Bug35.hs b/old-tests/Bugs/Bug35.hs deleted file mode 100644 index 5e187c1..0000000 --- a/old-tests/Bugs/Bug35.hs +++ /dev/null @@ -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 diff --git a/old-tests/Bugs/Bug39.hs b/old-tests/Bugs/Bug39.hs deleted file mode 100644 index 716030d..0000000 --- a/old-tests/Bugs/Bug39.hs +++ /dev/null @@ -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 diff --git a/old-tests/Bugs/Bug6.hs b/old-tests/Bugs/Bug6.hs deleted file mode 100644 index 5a6fc47..0000000 --- a/old-tests/Bugs/Bug6.hs +++ /dev/null @@ -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 diff --git a/old-tests/Bugs/Bug9.hs b/old-tests/Bugs/Bug9.hs deleted file mode 100644 index ab555f3..0000000 --- a/old-tests/Bugs/Bug9.hs +++ /dev/null @@ -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 ">>>") ]] diff --git a/old-tests/Main.hs b/old-tests/Main.hs deleted file mode 100644 index 3edee2e..0000000 --- a/old-tests/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Test.Framework - -import Bugs (bugs) - -main :: IO () -main = defaultMain [testGroup "Bugs" bugs] diff --git a/old-tests/Util.hs b/old-tests/Util.hs deleted file mode 100644 index 00f32c5..0000000 --- a/old-tests/Util.hs +++ /dev/null @@ -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 _ -> [] diff --git a/stack.yaml b/stack.yaml index 3906fe9..5fe4736 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-6.11 +resolver: lts-6.15 packages: - '.' diff --git a/tests/Char.hs b/tests/Char.hs deleted file mode 100644 index b5893a6..0000000 --- a/tests/Char.hs +++ /dev/null @@ -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 diff --git a/tests/Combinator.hs b/tests/Combinator.hs deleted file mode 100644 index 694a0a9..0000000 --- a/tests/Combinator.hs +++ /dev/null @@ -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 diff --git a/tests/Error.hs b/tests/Error.hs deleted file mode 100644 index d8f290e..0000000 --- a/tests/Error.hs +++ /dev/null @@ -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 diff --git a/tests/Lexer.hs b/tests/Lexer.hs deleted file mode 100644 index d919377..0000000 --- a/tests/Lexer.hs +++ /dev/null @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 index d441e79..0000000 --- a/tests/Main.hs +++ /dev/null @@ -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 ] diff --git a/tests/Perm.hs b/tests/Perm.hs deleted file mode 100644 index 2082937..0000000 --- a/tests/Perm.hs +++ /dev/null @@ -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 diff --git a/tests/Pos.hs b/tests/Pos.hs deleted file mode 100644 index 2f49858..0000000 --- a/tests/Pos.hs +++ /dev/null @@ -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) diff --git a/tests/Prim.hs b/tests/Prim.hs deleted file mode 100644 index b60bd5d..0000000 --- a/tests/Prim.hs +++ /dev/null @@ -1,1017 +0,0 @@ --- --- QuickCheck tests for Megaparsec's primitive 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 FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Prim (tests) where - -import Control.Applicative -import Control.Monad.Cont -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.Reader -import Data.Char (isLetter, toUpper, chr) -import Data.Foldable (asum) -import Data.List (isPrefixOf, foldl') -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (maybeToList, fromMaybe) -import Data.Proxy -import Data.Set (Set) -import Data.Word (Word8) -import Prelude hiding (span) -import qualified Control.Monad.State.Lazy as L -import qualified Control.Monad.State.Strict as S -import qualified Control.Monad.Writer.Lazy as L -import qualified Control.Monad.Writer.Strict as S -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Test.Framework -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck hiding (label) -import Test.HUnit (Assertion) - -import Text.Megaparsec.Char -import Text.Megaparsec.Combinator -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import Text.Megaparsec.Prim -import Text.Megaparsec.String - -import Pos () -import Error () -import Util - -tests :: Test -tests = testGroup "Primitive parser combinators" - [ testProperty "Stream lazy byte string" prop_byteStringL - , testProperty "Stream lazy byte string (pos)" prop_byteStringL_pos - , testProperty "Stream strict byte string" prop_byteStringS - , testProperty "Stream strict byte string (pos)" prop_byteStringS_pos - , testProperty "Stream lazy text" prop_textL - , testProperty "Stream lazy text (pos)" prop_textL_pos - , testProperty "Stream strict text" prop_textS - , testProperty "Stream strict text (pos)" prop_textS_pos - , testProperty "position in custom stream, eof" prop_cst_eof - , testProperty "position in custom stream, token" prop_cst_token - , testProperty "position in custom stream, tokens" prop_cst_tokens - , testProperty "ParsecT functor" prop_functor - , testProperty "ParsecT applicative (<*>)" prop_applicative_0 - , testProperty "ParsecT applicative (<*>) meok-cerr" prop_applicative_1 - , testProperty "ParsecT applicative (*>)" prop_applicative_2 - , testProperty "ParsecT applicative (<*)" prop_applicative_3 - , testProperty "ParsecT alternative empty and (<|>)" prop_alternative_0 - , testProperty "ParsecT alternative (<|>)" prop_alternative_1 - , testProperty "ParsecT alternative (<|>) pos" prop_alternative_2 - , testProperty "ParsecT alternative (<|>) hints" prop_alternative_3 - , testProperty "ParsecT alternative many" prop_alternative_4 - , testProperty "ParsecT alternative some" prop_alternative_5 - , testProperty "ParsecT alternative optional" prop_alternative_6 - , testProperty "ParsecT monad return" prop_monad_0 - , testProperty "ParsecT monad (>>)" prop_monad_1 - , testProperty "ParsecT monad (>>=)" prop_monad_2 - , testProperty "ParsecT monad fail" prop_monad_3 - , testProperty "ParsecT monad laws: left identity" prop_monad_left_id - , testProperty "ParsecT monad laws: right identity" prop_monad_right_id - , testProperty "ParsecT monad laws: associativity" prop_monad_assoc - , testProperty "ParsecT monad io (liftIO)" prop_monad_io - , testProperty "ParsecT monad reader ask" prop_monad_reader_ask - , testProperty "ParsecT monad reader local" prop_monad_reader_local - , testProperty "ParsecT monad state get" prop_monad_state_get - , testProperty "ParsecT monad state put" prop_monad_state_put - , testProperty "ParsecT monad cont" prop_monad_cont - , testProperty "ParsecT monad error: throw" prop_monad_error_throw - , testProperty "ParsecT monad error: catch" prop_monad_error_catch - , testProperty "combinator unexpected" prop_unexpected - , testProperty "combinator failure" prop_failure - , testProperty "combinator label" prop_label - , testProperty "combinator hidden hints" prop_hidden_0 - , testProperty "combinator hidden error" prop_hidden_1 - , testProperty "combinator try" prop_try - , testProperty "combinator lookAhead" prop_lookAhead_0 - , testProperty "combinator lookAhead hints" prop_lookAhead_1 - , testProperty "combinator lookAhead messages" prop_lookAhead_2 - , testCase "combinator lookAhead cerr" case_lookAhead_3 - , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 - , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1 - , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 - , testCase "combinator notFollowedBy cerr" case_notFollowedBy_3a - , testCase "combinator notFollowedBy cerr" case_notFollowedBy_3b - , testCase "combinator notFollowedBy eerr" case_notFollowedBy_4a - , testCase "combinator notFollowedBy eerr" case_notFollowedBy_4b - , testProperty "combinator withRecovery" prop_withRecovery_0 - , testCase "combinator withRecovery eok" case_withRecovery_1 - , testCase "combinator withRecovery meerr-rcerr" case_withRecovery_2 - , testCase "combinator withRecovery meerr-reok" case_withRecovery_3a - , testCase "combinator withRecovery meerr-reok" case_withRecovery_3b - , testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4a - , testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4b - , testCase "combinator withRecovery mcerr-rcerr" case_withRecovery_5 - , testCase "combinator withRecovery mcerr-reok" case_withRecovery_6a - , testCase "combinator withRecovery mcerr-reok" case_withRecovery_6b - , testCase "combinator withRecovery mcerr-reerr" case_withRecovery_7 - , testCase "combinator eof return value" case_eof - , testProperty "combinator token" prop_token - , testProperty "combinator tokens" prop_tokens_0 - , testProperty "combinator tokens (consumption)" prop_tokens_1 - , testProperty "parser state position" prop_state_pos - , testProperty "parser state position (push)" prop_state_pushPosition - , testProperty "parser state position (pop)" prop_state_popPosition - , testProperty "parser state input" prop_state_input - , testProperty "parser state tab width" prop_state_tab - , testProperty "parser state general" prop_state - , testProperty "parseMaybe" prop_parseMaybe - , testProperty "custom state parsing" prop_runParser' - , testProperty "custom state parsing (transformer)" prop_runParserT' - , testProperty "state on failure (mplus)" prop_stOnFail_0 - , testProperty "state on failure (tab)" prop_stOnFail_1 - , testProperty "state on failure (eof)" prop_stOnFail_2 - , testProperty "state on failure (notFollowedBy)" prop_stOnFail_3 - , testProperty "ReaderT try" prop_ReaderT_try - , testProperty "ReaderT notFollowedBy" prop_ReaderT_notFollowedBy - , testProperty "StateT alternative (<|>)" prop_StateT_alternative - , testProperty "StateT lookAhead" prop_StateT_lookAhead - , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy - , testProperty "WriterT" prop_WriterT ] - -instance Arbitrary a => Arbitrary (State a) where - arbitrary = State - <$> arbitrary - <*> arbitrary - <*> (unsafePos <$> choose (1, 20)) - --- Various instances of Stream - -prop_byteStringL :: Word8 -> NonNegative Int -> Property -prop_byteStringL ch' n = parse p "" (BL.pack s) === Right s - where p = many (char ch) :: Parsec Dec BL.ByteString String - s = replicate (getNonNegative n) ch - ch = byteToChar ch' - -prop_byteStringL_pos :: Pos -> SourcePos -> Char -> Property -prop_byteStringL_pos w pos ch = - updatePos (Proxy :: Proxy String) w pos ch === - updatePos (Proxy :: Proxy BL.ByteString) w pos ch - -prop_byteStringS :: Word8 -> NonNegative Int -> Property -prop_byteStringS ch' n = parse p "" (B.pack s) === Right s - where p = many (char ch) :: Parsec Dec B.ByteString String - s = replicate (getNonNegative n) ch - ch = byteToChar ch' - -prop_byteStringS_pos :: Pos -> SourcePos -> Char -> Property -prop_byteStringS_pos w pos ch = - updatePos (Proxy :: Proxy String) w pos ch === - updatePos (Proxy :: Proxy B.ByteString) w pos ch - -byteToChar :: Word8 -> Char -byteToChar = chr . fromIntegral - -prop_textL :: Char -> NonNegative Int -> Property -prop_textL ch n = parse p "" (TL.pack s) === Right s - where p = many (char ch) :: Parsec Dec TL.Text String - s = replicate (getNonNegative n) ch - -prop_textL_pos :: Pos -> SourcePos -> Char -> Property -prop_textL_pos w pos ch = - updatePos (Proxy :: Proxy String) w pos ch === - updatePos (Proxy :: Proxy TL.Text) w pos ch - -prop_textS :: Char -> NonNegative Int -> Property -prop_textS ch n = parse p "" (T.pack s) === Right s - where p = many (char ch) :: Parsec Dec T.Text String - s = replicate (getNonNegative n) ch - -prop_textS_pos :: Pos -> SourcePos -> Char -> Property -prop_textS_pos w pos ch = - updatePos (Proxy :: Proxy String) w pos ch === - updatePos (Proxy :: Proxy T.Text) w pos ch - --- Custom stream of tokens and position advancing - --- | This data type will represent tokens in input stream for the purposes --- of next several tests. - -data Span = Span - { spanStart :: SourcePos - , spanEnd :: SourcePos - , spanBody :: NonEmpty Char - } deriving (Eq, Ord, Show) - -instance Stream [Span] where - type Token [Span] = Span - uncons [] = Nothing - uncons (t:ts) = Just (t, ts) - updatePos _ _ _ (Span start end _) = (start, end) - -instance Arbitrary Span where - arbitrary = do - start <- arbitrary - end <- arbitrary `suchThat` (> start) - Span start end <$> arbitrary - -type CustomParser = Parsec Dec [Span] - -prop_cst_eof :: State [Span] -> Property -prop_cst_eof st = - (not . null . stateInput) st ==> (runParser' p st === r) - where - p = eof :: CustomParser () - h = head (stateInput st) - apos = let (_:|z) = statePos st in spanStart h :| z - r = (st { statePos = apos }, Left ParseError - { errorPos = apos - , errorUnexpected = E.singleton (Tokens (nes h)) - , errorExpected = E.singleton EndOfInput - , errorCustom = E.empty }) - -prop_cst_token :: State [Span] -> Span -> Property -prop_cst_token st@State {..} span = runParser' p st === r - where - p = pSpan span - h = head stateInput - (apos, npos) = - let z = NE.tail statePos - in (spanStart h :| z, spanEnd h :| z) - r | null stateInput = - ( st - , Left ParseError - { errorPos = statePos - , errorUnexpected = E.singleton EndOfInput - , errorExpected = E.singleton (Tokens $ nes span) - , errorCustom = E.empty } ) - | spanBody h == spanBody span = - ( st { statePos = npos - , stateInput = tail stateInput } - , Right span ) - | otherwise = - ( st { statePos = apos } - , Left ParseError - { errorPos = apos - , errorUnexpected = E.singleton (Tokens $ nes h) - , errorExpected = E.singleton (Tokens $ nes span) - , errorCustom = E.empty } ) - -pSpan :: Span -> CustomParser Span -pSpan span = token testToken (Just span) - where - f = E.singleton . Tokens . nes - testToken x = - if spanBody x == spanBody span - then Right span - else Left (f x, f span , E.empty) - -prop_cst_tokens :: State [Span] -> [Span] -> Property -prop_cst_tokens st' ts = - forAll (incCoincidence st' ts) $ \st@State {..} -> - let - p = tokens compareTokens ts :: CustomParser [Span] - compareTokens x y = spanBody x == spanBody y - updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth - ts' = NE.fromList ts - il = length . takeWhile id $ zipWith compareTokens stateInput ts - tl = length ts - consumed = take il stateInput - (apos, npos) = - let (pos:|z) = statePos - in ( spanStart (head stateInput) :| z - , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) - r | null ts = (st, Right []) - | null stateInput = - ( st - , Left ParseError - { errorPos = statePos - , errorUnexpected = E.singleton EndOfInput - , errorExpected = E.singleton (Tokens ts') - , errorCustom = E.empty } ) - | il == tl = - ( st { statePos = npos - , stateInput = drop (length ts) stateInput } - , Right consumed ) - | otherwise = - ( st { statePos = apos } - , Left ParseError - { errorPos = apos - , errorUnexpected = E.singleton - (Tokens . NE.fromList $ take (il + 1) stateInput) - , errorExpected = E.singleton (Tokens ts') - , errorCustom = E.empty } ) - in runParser' p st === r - -incCoincidence :: State [Span] -> [Span] -> Gen (State [Span]) -incCoincidence st ts = do - n <- getSmall <$> arbitrary - let (pre, post) = splitAt n (stateInput st) - pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts - return st { stateInput = pre' ++ post } - --- Functor instance - -prop_functor :: Integer -> Integer -> Property -prop_functor n m = - ((+ m) <$> return n) /=\ n + m .&&. ((* n) <$> return m) /=\ n * m - --- Applicative instance - -prop_applicative_0 :: Integer -> Integer -> Property -prop_applicative_0 n m = ((+) <$> pure n <*> pure m) /=\ n + m - -prop_applicative_1 :: Char -> Char -> Property -prop_applicative_1 a b = a /= b ==> checkParser p r s - where - p = pure toUpper <*> (char a >> char a) - r = posErr 1 s [utok b, etok a] - s = [a,b] - -prop_applicative_2 :: Integer -> Integer -> Property -prop_applicative_2 n m = (pure n *> pure m) /=\ m - -prop_applicative_3 :: Integer -> Integer -> Property -prop_applicative_3 n m = (pure n <* pure m) /=\ n - --- Alternative instance - -prop_alternative_0 :: Integer -> Property -prop_alternative_0 n = (empty <|> return n) /=\ n - -prop_alternative_1 :: String -> String -> Property -prop_alternative_1 s0 s1 - | s0 == s1 = checkParser p (Right s0) s1 - | null s0 = checkParser p (posErr 0 s1 [utok (head s1), eeof]) s1 - | s0 `isPrefixOf` s1 = - checkParser p (posErr s0l s1 [utok (s1 !! s0l), eeof]) s1 - | otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1 - where p = string s0 <|> string s1 - s0l = length s0 - -prop_alternative_2 :: Char -> Char -> Char -> Bool -> Property -prop_alternative_2 a b c l = checkParser p r s - where p = char a <|> (char b >> char a) - r | l = Right a - | a == b = posErr 1 s [utok c, eeof] - | a == c = Right a - | otherwise = posErr 1 s [utok c, etok a] - s = if l then [a] else [b,c] - -prop_alternative_3 :: Property -prop_alternative_3 = checkParser p r s - where p = asum [empty, string ">>>", empty, return "foo"] "bar" - p' = bsum [empty, string ">>>", empty, return "foo"] "bar" - bsum = foldl (<|>) empty - r = simpleParse p' s - s = ">>" - -prop_alternative_4 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_alternative_4 a' b' c' = checkParser p r s - where [a,b,c] = getNonNegative <$> [a',b',c'] - p = (++) <$> many (char 'a') <*> many (char 'b') - r | null s = Right s - | c > 0 = posErr (a + b) s $ [utok 'c', etok 'b', eeof] - ++ [etok 'a' | b == 0] - | otherwise = Right s - s = abcRow a b c - -prop_alternative_5 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_alternative_5 a' b' c' = checkParser p r s - where [a,b,c] = getNonNegative <$> [a',b',c'] - p = (++) <$> some (char 'a') <*> some (char 'b') - r | null s = posErr 0 s [ueof, etok 'a'] - | a == 0 = posErr 0 s [utok (head s), etok 'a'] - | b == 0 = posErr a s $ [etok 'a', etok 'b'] ++ - if c > 0 then [utok 'c'] else [ueof] - | c > 0 = posErr (a + b) s [utok 'c', etok 'b', eeof] - | otherwise = Right s - s = abcRow a b c - -prop_alternative_6 :: Bool -> Bool -> Bool -> Property -prop_alternative_6 a b c = checkParser p r s - where p = f <$> optional (char 'a') <*> optional (char 'b') - f x y = maybe "" (:[]) x ++ maybe "" (:[]) y - r | c = posErr ab s $ [utok 'c', eeof] ++ - [etok 'a' | not a && not b] ++ [etok 'b' | not b] - | otherwise = Right s - s = abcRow a b c - ab = fromEnum a + fromEnum b - --- Monad instance - -prop_monad_0 :: Integer -> Property -prop_monad_0 n = checkParser (return n) (Right n) "" - -prop_monad_1 :: Char -> Char -> Maybe Char -> Property -prop_monad_1 a b c = checkParser p r s - where p = char a >> char b - r = simpleParse (char a *> char b) s - s = a : b : maybeToList c - -prop_monad_2 :: Char -> Char -> Maybe Char -> Property -prop_monad_2 a b c = checkParser p r s - where p = char a >>= \x -> char b >> return x - r = simpleParse (char a <* char b) s - s = a : b : maybeToList c - -prop_monad_3 :: String -> Property -prop_monad_3 msg = checkParser p r s - where p = fail msg :: Parser () - r = posErr 0 s [cstm (DecFail msg)] - s = "" - -prop_monad_left_id :: Integer -> Integer -> Property -prop_monad_left_id a b = (return a >>= f) !=! f a - where f x = return $ x + b - -prop_monad_right_id :: Integer -> Property -prop_monad_right_id a = (m >>= return) !=! m - where m = return a - -prop_monad_assoc :: Integer -> Integer -> Integer -> Property -prop_monad_assoc a b c = ((m >>= f) >>= g) !=! (m >>= (\x -> f x >>= g)) - where m = return a - f x = return $ x + b - g x = return $ x + c - --- MonadIO instance - -prop_monad_io :: Integer -> Property -prop_monad_io n = ioProperty (liftM (=== Right n) (runParserT p "" "")) - where p = liftIO (return n) :: ParsecT Dec String IO Integer - --- MonadReader instance - -prop_monad_reader_ask :: Integer -> Property -prop_monad_reader_ask a = runReader (runParserT p "" "") a === Right a - where p = ask :: ParsecT Dec String (Reader Integer) Integer - -prop_monad_reader_local :: Integer -> Integer -> Property -prop_monad_reader_local a b = - runReader (runParserT p "" "") a === Right (a + b) - where p = local (+ b) ask :: ParsecT Dec String (Reader Integer) Integer - --- MonadState instance - -prop_monad_state_get :: Integer -> Property -prop_monad_state_get a = L.evalState (runParserT p "" "") a === Right a - where p = L.get :: ParsecT Dec String (L.State Integer) Integer - -prop_monad_state_put :: Integer -> Integer -> Property -prop_monad_state_put a b = L.execState (runParserT p "" "") a === b - where p = L.put b :: ParsecT Dec String (L.State Integer) () - --- MonadCont instance - -prop_monad_cont :: Integer -> Integer -> Property -prop_monad_cont a b = runCont (runParserT p "" "") id === Right (max a b) - where p :: ParsecT Dec String - (Cont (Either (ParseError Char Dec) Integer)) Integer - p = do x <- callCC $ \e -> when (a > b) (e a) >> return b - return x - --- MonadError instance - -prop_monad_error_throw :: Integer -> Integer -> Property -prop_monad_error_throw a b = runExcept (runParserT p "" "") === Left a - where p :: ParsecT Dec String (Except Integer) Integer - p = throwError a >> return b - -prop_monad_error_catch :: Integer -> Integer -> Property -prop_monad_error_catch a b = - runExcept (runParserT p "" "") === Right (Right $ a + b) - where p :: ParsecT Dec String (Except Integer) Integer - p = (throwError a >> return b) `catchError` handler - handler e = return (e + b) - --- Primitive combinators - -prop_unexpected :: ErrorItem Char -> Property -prop_unexpected item = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = unexpected item - r = posErr 0 s [Unexpected item] - s = "" - -prop_failure - :: Set (ErrorItem Char) - -> Set (ErrorItem Char) - -> Set Dec - -> Property -prop_failure us ps xs = checkParser' p r s - where p :: (MonadParsec Dec s m, Token s ~ Char) => m String - p = failure us ps xs - r = Left ParseError - { errorPos = nes (initialPos "") - , errorUnexpected = us - , errorExpected = ps - , errorCustom = xs } - s = "" - -prop_label :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> String -> Property -prop_label a' b' c' l = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = (++) <$> many (char 'a') <*> (many (char 'b') l) - r | null s = Right s - | c > 0 = posErr (a + b) s $ [utok 'c', eeof] - ++ [etok 'a' | b == 0] - ++ (if null l - then [] - else [if b == 0 - then elabel l - else elabel ("rest of " ++ l)]) - | otherwise = Right s - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -prop_hidden_0 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_hidden_0 a' b' c' = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = (++) <$> many (char 'a') <*> hidden (many (char 'b')) - r | null s = Right s - | c > 0 = posErr (a + b) s $ [utok 'c', eeof] - ++ [etok 'a' | b == 0] - | otherwise = Right s - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -prop_hidden_1 :: NonEmptyList Char -> String -> Property -prop_hidden_1 c' s = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m (Maybe String) - p = optional (hidden $ string c) - r | null s = Right Nothing - | c == s = Right (Just s) - | c `isPrefixOf` s = posErr cn s [utok (s !! cn), eeof] - | otherwise = posErr 0 s [utok (head s), eeof] - c = getNonEmpty c' - cn = length c - -prop_try :: Char -> Char -> Char -> Property -prop_try pre ch1 ch2 = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = try (sequence [char pre, char ch1]) - <|> sequence [char pre, char ch2] - r = posErr 1 s [ueof, etok ch1, etok ch2] - s = [pre] - -prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property -prop_lookAhead_0 a b c = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m Char - p = do - l <- lookAhead (oneOf "ab" "label") - guard (l == h) - char 'a' - h = head s - r | null s = posErr 0 s [ueof, elabel "label"] - | s == "a" = Right 'a' - | h == 'b' = posErr 0 s [utok 'b', etok 'a'] - | h == 'c' = posErr 0 s [utok 'c', elabel "label"] - | otherwise = posErr 1 s [utok (s !! 1), eeof] - s = abcRow a b c - -prop_lookAhead_1 :: String -> Property -prop_lookAhead_1 s = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m () - p = lookAhead (some letterChar) >> fail emsg - h = head s - r | null s = posErr 0 s [ueof, elabel "letter"] - | isLetter h = posErr 0 s [cstm (DecFail emsg)] - | otherwise = posErr 0 s [utok h, elabel "letter"] - emsg = "ops!" - -prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property -prop_lookAhead_2 a b c = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m Char - p = lookAhead (some (char 'a')) >> char 'b' - r | null s = posErr 0 s [ueof, etok 'a'] - | a = posErr 0 s [utok 'a', etok 'b'] - | otherwise = posErr 0 s [utok (head s), etok 'a'] - s = abcRow a b c - -case_lookAhead_3 :: Assertion -case_lookAhead_3 = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = lookAhead (char 'a' *> fail emsg) - r = posErr 1 s [cstm (DecFail emsg)] - emsg = "ops!" - s = "abc" - -prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_notFollowedBy_0 a' b' c' = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c') - r | b > 0 = posErr a s [utok 'b', etok 'a'] - | otherwise = Right (replicate a 'a') - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_notFollowedBy_1 a' b' c' = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = many (char 'a') - <* (notFollowedBy . notFollowedBy) (char 'c') - <* many (char 'c') - r | b == 0 && c > 0 = Right (replicate a 'a') - | b > 0 = posErr a s [utok 'b', etok 'a'] - | otherwise = posErr a s [ueof, etok 'a'] - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_notFollowedBy_2 a' b' c' = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = many (char 'a') <* notFollowedBy eof <* many anyChar - r | b > 0 || c > 0 = Right (replicate a 'a') - | otherwise = posErr a s [ueof, etok 'a'] - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -case_notFollowedBy_3a :: Assertion -case_notFollowedBy_3a = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m () - p = notFollowedBy (char 'a' *> char 'c') - r = Right () - s = "ab" - -case_notFollowedBy_3b :: Assertion -case_notFollowedBy_3b = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m () - p = notFollowedBy (char 'a' *> char 'd') <* char 'c' - r = posErr 0 s [utok 'a', etok 'c'] - s = "ab" - -case_notFollowedBy_4a :: Assertion -case_notFollowedBy_4a = checkCase' p r s - where p :: MonadParsec e s m => m () - p = notFollowedBy mzero - r = Right () - s = "ab" - -case_notFollowedBy_4b :: Assertion -case_notFollowedBy_4b = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m () - p = notFollowedBy mzero <* char 'c' - r = posErr 0 s [utok 'a', etok 'c'] - s = "ab" - -prop_withRecovery_0 - :: NonNegative Int - -> NonNegative Int - -> NonNegative Int - -> Property -prop_withRecovery_0 a' b' c' = checkParser' p r s - where - p :: (MonadParsec Dec s m, Token s ~ Char) - => m (Either (ParseError Char Dec) String) - p = let g = count' 1 3 . char in v <$> - withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c' - v (Right x) y = Right (x ++ y) - v (Left m) _ = Left m - r | a == 0 && b == 0 && c == 0 = posErr 0 s [ueof, etok 'a'] - | a == 0 && b == 0 && c > 3 = posErr 0 s [utok 'c', etok 'a'] - | a == 0 && b == 0 = posErr 0 s [utok 'c', etok 'a'] - | a == 0 && b > 3 = posErr 3 s [utok 'b', etok 'a', etok 'c'] - | a == 0 && c == 0 = posErr b s [ueof, etok 'a', etok 'c'] - | a == 0 && c > 3 = posErr (b + 3) s [utok 'c', eeof] - | a == 0 = Right (posErr 0 s [utok 'b', etok 'a']) - | a > 3 = posErr 3 s [utok 'a', etok 'c'] - | b == 0 && c == 0 = posErr a s $ [ueof, etok 'c'] ++ ma - | b == 0 && c > 3 = posErr (a + 3) s [utok 'c', eeof] - | b == 0 = Right (Right s) - | otherwise = posErr a s $ [utok 'b', etok 'c'] ++ ma - ma = [etok 'a' | a < 3] - s = abcRow a b c - [a,b,c] = getNonNegative <$> [a',b',c'] - -case_withRecovery_1 :: Assertion -case_withRecovery_1 = checkCase' p r s - where p :: MonadParsec e s m => m String - p = withRecovery (const $ return "bar") (return "foo") - r = Right "foo" - s = "abc" - -case_withRecovery_2 :: Assertion -case_withRecovery_2 = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (\_ -> char 'a' *> mzero) (string "cba") - r = posErr 0 s [utoks "a", etoks "cba"] - s = "abc" - -case_withRecovery_3a :: Assertion -case_withRecovery_3a = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (const $ return "abd") (string "cba") - r = Right "abd" - s = "abc" - -case_withRecovery_3b :: Assertion -case_withRecovery_3b = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (const $ return "abd") (string "cba") <* char 'd' - r = posErr 0 s [utok 'a', etoks "cba", etok 'd'] - s = "abc" - -case_withRecovery_4a :: Assertion -case_withRecovery_4a = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (const $ string "bc") (char 'a' *> mzero) - r = Right "bc" - s = "abc" - -case_withRecovery_4b :: Assertion -case_withRecovery_4b = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (const $ string "bc") - (char 'a' *> char 'd' *> pure "foo") <* char 'f' - r = posErr 3 s [ueof, etok 'f'] - s = "abc" - -case_withRecovery_5 :: Assertion -case_withRecovery_5 = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail emsg) - r = posErr 1 s [cstm (DecFail emsg)] - emsg = "ops!" - s = "abc" - -case_withRecovery_6a :: Assertion -case_withRecovery_6a = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m String - p = withRecovery (const $ return "abd") (char 'a' *> mzero) - r = Right "abd" - s = "abc" - -case_withRecovery_6b :: Assertion -case_withRecovery_6b = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m Char - p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f' - r = posErr 1 s [utok 'b', etok 'd', etok 'f'] - s = "abc" - -case_withRecovery_7 :: Assertion -case_withRecovery_7 = checkCase' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m Char - p = withRecovery (const mzero) (char 'a' *> char 'd') - r = posErr 1 s [utok 'b', etok 'd'] - s = "abc" - -case_eof :: Assertion -case_eof = checkCase' eof (Right ()) "" - -prop_token :: Maybe Char -> String -> Property -prop_token mtok s = checkParser' p r s - where p :: (MonadParsec e s m, Token s ~ Char) => m Char - p = token testChar mtok - testChar x = if isLetter x - then Right x - else Left (E.singleton (Tokens $ nes x), E.empty, E.empty) - h = head s - r | null s = posErr 0 s $ ueof : maybeToList (etok <$> mtok) - | isLetter h && length s == 1 = Right (head s) - | isLetter h && length s > 1 = posErr 1 s [utok (s !! 1), eeof] - | otherwise = posErr 0 s [utok h] - -prop_tokens_0 :: String -> String -> Property -prop_tokens_0 a = checkString (tokens (==) a) a (==) - -prop_tokens_1 :: String -> String -> String -> Property -prop_tokens_1 pre post post' = - not (post `isPrefixOf` post') ==> - (leftover === "" .||. leftover === s) - where p :: Parser String - p = tokens (==) (pre ++ post) - s = pre ++ post' - st = stateFromInput s - leftover = stateInput . fst $ runParser' p st - --- Parser state combinators - -prop_state_pos :: State String -> SourcePos -> Property -prop_state_pos st pos = runParser' p st === r - where p = (setPosition pos >> getPosition) :: Parser SourcePos - r = (f st pos, Right pos) - f (State s (_:|xs) w) y = State s (y:|xs) w - -prop_state_pushPosition :: State String -> SourcePos -> Property -prop_state_pushPosition st pos = fst (runParser' p st) === r - where p = pushPosition pos :: Parser () - r = st { statePos = NE.cons pos (statePos st) } - -prop_state_popPosition :: State String -> Property -prop_state_popPosition st = fst (runParser' p st) === r - where p = popPosition :: Parser () - r = st { statePos = fromMaybe pos (snd (NE.uncons pos)) } - pos = statePos st - -prop_state_input :: String -> Property -prop_state_input s = p /=\ s - where p = do - st0 <- getInput - guard (null st0) - setInput s - result <- string s - st1 <- getInput - guard (null st1) - return result - -prop_state_tab :: Pos -> Property -prop_state_tab w = p /=\ w - where p = setTabWidth w >> getTabWidth - -prop_state :: State String -> State String -> Property -prop_state s1 s2 = checkParser' p r s - where p :: MonadParsec Dec String m => m (State String) - p = do - st <- getParserState - guard (st == State s (nes $ initialPos "") defaultTabWidth) - setParserState s1 - updateParserState (f s2) - liftM2 const getParserState (setInput "") - f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w - r = Right (f s2 s1) - s = "" - --- Running a parser - -prop_parseMaybe :: String -> String -> Property -prop_parseMaybe s s' = parseMaybe p s === r - where p = string s' :: Parser String - r = if s == s' then Just s else Nothing - -prop_runParser' :: State String -> String -> Property -prop_runParser' st s = runParser' p st === r - where p = string s - r = emulateStrParsing st s - -prop_runParserT' :: State String -> String -> Property -prop_runParserT' st s = runIdentity (runParserT' p st) === r - where p = string s - r = emulateStrParsing st s - -emulateStrParsing - :: State String - -> String - -> (State String, Either (ParseError Char Dec) String) -emulateStrParsing st@(State i (pos:|z) t) s = - if l == length s - then (State (drop l i) (updatePosString t pos s :| z) t, Right s) - else (st, posErr' (pos:|z) (etoks s : [utoks (take (l + 1) i)])) - where l = length (takeWhile id $ zipWith (==) s i) - --- Additional tests to check returned state on failure - -prop_stOnFail_0 :: Positive Int -> Positive Int -> Property -prop_stOnFail_0 na' nb' = runParser' p (stateFromInput s) === (i, r) - where i = let (Left x) = r in State "" (errorPos x) defaultTabWidth - na = getPositive na' - nb = getPositive nb' - p = try (many (char 'a') <* many (char 'b') <* char 'c') - <|> (many (char 'a') <* char 'c') - r = posErr (na + nb) s [etok 'b', etok 'c', ueof] - s = replicate na 'a' ++ replicate nb 'b' - -prop_stOnFail_1 :: Positive Int -> Pos -> Property -prop_stOnFail_1 na' t = runParser' p (stateFromInput s) === (i, r) - where i = let (Left x) = r in State "" (errorPos x) t - na = getPositive na' - p = many (char 'a') <* setTabWidth t <* fail emsg - r = posErr na s [cstm (DecFail emsg)] - s = replicate na 'a' - emsg = "failing now!" - -prop_stOnFail_2 :: String -> Char -> Property -prop_stOnFail_2 s' ch = runParser' p (stateFromInput s) === (i, r) - where i = let (Left x) = r in State [ch] (errorPos x) defaultTabWidth - r = posErr (length s') s [utok ch, eeof] - p = string s' <* eof - s = s' ++ [ch] - -prop_stOnFail_3 :: String -> Property -prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r) - where i = let (Left x) = r in State s (errorPos x) defaultTabWidth - r = posErr 0 s [if null s then ueof else utok (head s)] - p = notFollowedBy (string s) - -stateFromInput :: s -> State s -stateFromInput s = State s (nes $ initialPos "") defaultTabWidth - --- ReaderT instance of MonadParsec - -prop_ReaderT_try :: Char -> Char -> Char -> Property -prop_ReaderT_try pre ch1 ch2 = checkParser (runReaderT p (s1, s2)) r s - where s1 = pre : [ch1] - s2 = pre : [ch2] - getS1 = asks fst - getS2 = asks snd - p = try (g =<< getS1) <|> (g =<< getS2) - g = sequence . fmap char - r = posErr 1 s [ueof, etok ch1, etok ch2] - s = [pre] - -prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int - -> NonNegative Int -> Property -prop_ReaderT_notFollowedBy a' b' c' = checkParser (runReaderT p 'a') r s - where [a,b,c] = getNonNegative <$> [a',b',c'] - p = many (char =<< ask) <* notFollowedBy eof <* many anyChar - r | b > 0 || c > 0 = Right (replicate a 'a') - | otherwise = posErr a s [ueof, etok 'a'] - s = abcRow a b c - --- StateT instance of MonadParsec - -prop_StateT_alternative :: Integer -> Property -prop_StateT_alternative n = - checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" - where p = L.put n >> ((L.modify (* 2) >> - void (string "xxx")) <|> return ()) >> L.get - p' = S.put n >> ((S.modify (* 2) >> - void (string "xxx")) <|> return ()) >> S.get - -prop_StateT_lookAhead :: Integer -> Property -prop_StateT_lookAhead n = - checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" - where p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get - p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get - -prop_StateT_notFollowedBy :: Integer -> Property -prop_StateT_notFollowedBy n = checkParser (L.runStateT p 0) r "abx" .&&. - checkParser (S.runStateT p' 0) r "abx" - where p = do - L.put n - let notEof = notFollowedBy (L.modify (* 2) >> eof) - some (try (anyChar <* notEof)) <* char 'x' - p' = do - S.put n - let notEof = notFollowedBy (S.modify (* 2) >> eof) - some (try (anyChar <* notEof)) <* char 'x' - r = Right ("ab", n) - --- WriterT instance of MonadParsec - -prop_WriterT :: String -> String -> Property -prop_WriterT pre post = - checkParser (L.runWriterT p) r "abx" .&&. - checkParser (S.runWriterT p') r "abx" - where logged_letter = letterChar >>= \x -> L.tell [x] >> return x - logged_letter' = letterChar >>= \x -> L.tell [x] >> return x - logged_eof = eof >> L.tell "EOF" - logged_eof' = eof >> L.tell "EOF" - p = do - L.tell pre - cs <- L.censor (fmap toUpper) $ - some (try (logged_letter <* notFollowedBy logged_eof)) - L.tell post - void logged_letter - return cs - p' = do - L.tell pre - cs <- L.censor (fmap toUpper) $ - some (try (logged_letter' <* notFollowedBy logged_eof')) - L.tell post - void logged_letter' - return cs - r = Right ("ab", pre ++ "AB" ++ post ++ "x") - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 0000000..e8aacc8 --- /dev/null +++ b/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 diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs new file mode 100644 index 0000000..5a4bced --- /dev/null +++ b/tests/Test/Hspec/Megaparsec.hs @@ -0,0 +1,377 @@ +-- | +-- Module : Test.Hspec.Megaparsec +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions for testing Megaparsec parsers with Hspec. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Hspec.Megaparsec + ( -- * Basic expectations + shouldParse + , parseSatisfies + , shouldSucceedOn + , shouldFailOn + -- * Testing of error messages + , shouldFailWith + -- * Error message construction + -- $errmsg + , err + , posI + , posN + , EC + , utok + , utoks + , ulabel + , ueof + , etok + , etoks + , elabel + , eeof + , cstm + -- * Incremental parsing + , failsLeaving + , succeedsLeaving + , initialState ) +where + +import Control.Monad (unless) +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy +import Data.Semigroup +import Data.Set (Set) +import Data.Typeable (Typeable) +import GHC.Generics +import Test.Hspec.Expectations +import Text.Megaparsec +import Text.Megaparsec.Pos (defaultTabWidth) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E + +---------------------------------------------------------------------------- +-- Basic expectations + +-- | Create an expectation by saying what the result should be. +-- +-- > parse letterChar "" "x" `shouldParse` 'x' + +shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a) + => Either (ParseError t e) a + -- ^ Result of parsing as returned by function like 'parse' + -> a -- ^ Desired result + -> Expectation +r `shouldParse` v = case r of + Left e -> expectationFailure $ "expected: " ++ show v ++ + "\nbut parsing failed with error:\n" ++ showParseError e + Right x -> unless (x == v) . expectationFailure $ + "expected: " ++ show v ++ "\nbut got: " ++ show x + +-- | Create an expectation by saying that the parser should successfully +-- parse a value and that the value should satisfy some predicate. +-- +-- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length) + +parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) + => Either (ParseError t e) a + -- ^ Result of parsing as returned by function like 'parse' + -> (a -> Bool) -- ^ Predicate + -> Expectation +r `parseSatisfies` p = case r of + Left e -> expectationFailure $ + "expected a parsed value to check against the predicate" ++ + "\nbut parsing failed with error:\n" ++ showParseError e + Right x -> unless (p x) . expectationFailure $ + "the value did not satisfy the predicate: " ++ show x + +-- | Check that a parser fails on 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 diff --git a/tests/Test/Hspec/Megaparsec/AdHoc.hs b/tests/Test/Hspec/Megaparsec/AdHoc.hs new file mode 100644 index 0000000..542935f --- /dev/null +++ b/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)) diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs new file mode 100644 index 0000000..78321e6 --- /dev/null +++ b/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 diff --git a/tests/Text/Megaparsec/CombinatorSpec.hs b/tests/Text/Megaparsec/CombinatorSpec.hs new file mode 100644 index 0000000..728acad --- /dev/null +++ b/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 diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs new file mode 100644 index 0000000..60452ba --- /dev/null +++ b/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 diff --git a/tests/Expr.hs b/tests/Text/Megaparsec/ExprSpec.hs similarity index 77% rename from tests/Expr.hs rename to tests/Text/Megaparsec/ExprSpec.hs index e3c794e..8b8cd68 100644 --- a/tests/Expr.hs +++ b/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 Test.Framework -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Data.Monoid ((<>)) +import Test.Hspec +import Test.Hspec.Megaparsec +import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck - import Text.Megaparsec.Char import Text.Megaparsec.Combinator import Text.Megaparsec.Expr import Text.Megaparsec.Prim -import Util - #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), (<*>), (*>), pure) #endif -tests :: Test -tests = testGroup "Expression parsers" - [ testProperty "correctness of expression parser" prop_correctness - , testProperty "error message on empty input" prop_empty_error - , testProperty "error message on missing term" prop_missing_term - , testProperty "error message on missing op" prop_missing_op ] +spec :: Spec +spec = + describe "makeExprParser" $ do + context "when given valid rendered AST" $ + it "can parse it back" $ + property $ \node -> do + let s = showNode node + prs expr s `shouldParse` node + prs' expr s `succeedsLeaving` "" + context "when stream in empty" $ + it "signals correct parse error" $ + prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term") + context "when term is missing" $ + it "signals correct parse error" $ do + let p = expr <* eof + n = 1 :: Integer + prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term") + prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term") + prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term") + context "operator is missing" $ + it "signals correct parse error" $ + property $ \a b -> do + let p = expr <* eof + a' = inParens a + n = length a' + 1 + s = a' ++ " " ++ inParens b + c = s !! n + if c == '-' + then prs p s `shouldParse` Sub a b + else prs p s `shouldFailWith` + err (posN n s) (utok c <> eeof <> elabel "operator") -- Algebraic structures to build abstract syntax tree of our expression. @@ -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 diff --git a/tests/Text/Megaparsec/LexerSpec.hs b/tests/Text/Megaparsec/LexerSpec.hs new file mode 100644 index 0000000..6ffe23e --- /dev/null +++ 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) diff --git a/tests/Text/Megaparsec/PermSpec.hs b/tests/Text/Megaparsec/PermSpec.hs new file mode 100644 index 0000000..c7f64cd --- /dev/null +++ b/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' ) diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs new file mode 100644 index 0000000..60a476d --- /dev/null +++ b/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) diff --git a/tests/Text/Megaparsec/PrimSpec.hs b/tests/Text/Megaparsec/PrimSpec.hs new file mode 100644 index 0000000..19042f6 --- /dev/null +++ b/tests/Text/Megaparsec/PrimSpec.hs @@ -0,0 +1,1088 @@ +-- +-- Tests for Megaparsec's primitive 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 CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Text.Megaparsec.PrimSpec (spec) where + +import Control.Applicative +import Control.Monad.Cont +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Reader +import Data.Char (toUpper, chr) +import Data.Foldable (asum, concat) +import Data.List (isPrefixOf, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Proxy +import Data.Word (Word8) +import Prelude hiding (span, concat) +import Test.Hspec +import Test.Hspec.Megaparsec +import Test.Hspec.Megaparsec.AdHoc +import Test.QuickCheck hiding (label) +import Text.Megaparsec.Char +import Text.Megaparsec.Combinator +import Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.Prim +import Text.Megaparsec.String +import qualified Control.Monad.State.Lazy as L +import qualified Control.Monad.State.Strict as S +import qualified Control.Monad.Writer.Lazy as L +import qualified Control.Monad.Writer.Strict as S +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +spec :: Spec +spec = do + + describe "non-String instances of Stream" $ do + context "lazy ByteString" $ do + it "unconses correctly" $ + property $ \ch' n -> do + let p = many (char ch) :: Parsec Dec BL.ByteString String + s = replicate (getNonNegative n) ch + ch = byteToChar ch' + parse p "" (BL.pack s) `shouldParse` s + it "updates position like with String" $ + property $ \w pos ch -> + updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe` + updatePos (Proxy :: Proxy String) w pos ch + context "strict ByteString" $ do + it "unconses correctly" $ + property $ \ch' n -> do + let p = many (char ch) :: Parsec Dec B.ByteString String + s = replicate (getNonNegative n) ch + ch = byteToChar ch' + parse p "" (B.pack s) `shouldParse` s + it "updates position like with String" $ + property $ \w pos ch -> + updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe` + updatePos (Proxy :: Proxy String) w pos ch + context "lazy Text" $ do + it "unconses correctly" $ + property $ \ch n -> do + let p = many (char ch) :: Parsec Dec TL.Text String + s = replicate (getNonNegative n) ch + parse p "" (TL.pack s) `shouldParse` s + it "updates position like with String" $ + property $ \w pos ch -> + updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe` + updatePos (Proxy :: Proxy String) w pos ch + context "strict Text" $ do + it "unconses correctly" $ + property $ \ch n -> do + let p = many (char ch) :: Parsec Dec T.Text String + s = replicate (getNonNegative n) ch + parse p "" (T.pack s) `shouldParse` s + it "updates position like with String" $ + property $ \w pos ch -> + updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe` + updatePos (Proxy :: Proxy String) w pos ch + + describe "position in custom stream" $ do + + describe "eof" $ + it "updates position in stream correctly" $ + property $ \st -> (not . null . stateInput) st ==> do + let p = eof :: CustomParser () + h = head (stateInput st) + apos = let (_:|z) = statePos st in spanStart h :| z + runParser' p st `shouldBe` + ( st { statePos = apos } + , Left (err apos $ utok h <> eeof) ) + + describe "token" $ + it "updates position in stream correctly" $ + property $ \st@State {..} span -> do + let p = pSpan span + h = head stateInput + (apos, npos) = + let z = NE.tail statePos + in (spanStart h :| z, spanEnd h :| z) + if | null stateInput -> runParser' p st `shouldBe` + ( st + , Left (err statePos $ ueof <> etok span) ) + | spanBody h == spanBody span -> runParser' p st `shouldBe` + ( st { statePos = npos + , stateInput = tail stateInput } + , Right span ) + | otherwise -> runParser' p st `shouldBe` + ( st { statePos = apos} + , Left (err apos $ utok h <> etok span)) + + describe "tokens" $ + it "updates position is stream correctly" $ + property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do + let p = tokens compareTokens ts :: CustomParser [Span] + compareTokens x y = spanBody x == spanBody y + updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth + il = length . takeWhile id $ zipWith compareTokens stateInput ts + tl = length ts + consumed = take il stateInput + (apos, npos) = + let (pos:|z) = statePos + in ( spanStart (head stateInput) :| z + , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) + if | null ts -> runParser' p st `shouldBe` (st, Right []) + | null stateInput -> runParser' p st `shouldBe` + ( st + , Left (err statePos $ ueof <> etoks ts) ) + | il == tl -> runParser' p st `shouldBe` + ( st { statePos = npos + , stateInput = drop (length ts) stateInput } + , Right consumed ) + | otherwise -> runParser' p st `shouldBe` + ( st { statePos = apos } + , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) ) + + describe "ParsecT Functor instance" $ do + it "obeys identity law" $ + property $ \n -> + prs (fmap id (pure (n :: Int))) "" === + prs (id (pure n)) "" + it "obeys composition law" $ + property $ \n m t -> + let f = (+ m) + g = (* t) + in prs (fmap (f . g) (pure (n :: Int))) "" === + prs ((fmap f . fmap g) (pure n)) "" + + describe "ParsecT Applicative instance" $ do + it "obeys identity law" $ + property $ \n -> + prs (pure id <*> pure (n :: Int)) "" === + prs (pure n) "" + it "obeys composition law" $ + property $ \n m t -> + let u = pure (+ m) + v = pure (* t) + w = pure (n :: Int) + in prs (pure (.) <*> u <*> v <*> w) "" === + prs (u <*> (v <*> w)) "" + it "obeys homomorphism law" $ + property $ \x m -> + let f = (+ m) + in prs (pure f <*> pure (x :: Int)) "" === + prs (pure (f x)) "" + it "obeys interchange law" $ + property $ \n y -> + let u = pure (+ n) + in prs (u <*> pure (y :: Int)) "" === + prs (pure ($ y) <*> u) "" + it "(*>) works correctly" $ + property $ \n m -> + let u = pure (+ (m :: Int)) + v = pure (n :: Int) + in prs (u *> v) "" === + prs (pure (const id) <*> u <*> v) "" + it "(<*) works correctly" $ + property $ \n m -> + let u = pure (m :: Int) + v = pure (+ (n :: Int)) + in prs (u <* v) "" === prs (pure const <*> u <*> v) "" + + describe "ParsecT Alternative instance" $ do + + describe "empty" $ + it "always fails" $ + property $ \n -> + prs (empty <|> pure n) "" `shouldParse` (n :: Integer) + + describe "(<|>)" $ do + context "with two strings" $ do + context "stream begins with the first string" $ + it "parses the string" $ + property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do + let s' = s0 ++ s + p = string s0 <|> string s1 + prs p s' `shouldParse` s0 + prs' p s' `succeedsLeaving` s + context "stream begins with the second string" $ + it "parses the string" $ + property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do + let s' = s1 ++ s + p = string s0 <|> string s1 + prs p s' `shouldParse` s1 + prs' p s' `succeedsLeaving` s + context "when stream does not begin with either string" $ + it "signals correct error message" $ + property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do + let p = string s0 <|> string s1 + z0' = toFirstMismatch (==) s0 s + z1' = toFirstMismatch (==) s1 s + prs p s `shouldFailWith` err posI + (etoks s0 <> + etoks s1 <> + (if null s then ueof else mempty) <> + (if null z0' then mempty else utoks z0') <> + (if null z1' then mempty else utoks z1')) + context "with two complex parsers" $ do + context "when stream begins with matching character" $ + it "parses it" $ + property $ \a b -> a /= b ==> do + let p = char a <|> (char b *> char a) + s = [a] + prs p s `shouldParse` a + prs' p s `succeedsLeaving` "" + context "when stream begins with only one matching character" $ + it "signals correct parse error" $ + property $ \a b c -> a /= b && a /= c ==> do + let p = char a <|> (char b *> char a) + s = [b,c] + prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a) + prs' p s `failsLeaving` [c] + context "when stream begins with not matching character" $ + it "signals correct parse error" $ + property $ \a b c -> a /= b && a /= c && b /= c ==> do + let p = char a <|> (char b *> char a) + s = [c,b] + prs p s `shouldFailWith` err posI (utok c <> etok a <> etok b) + prs' p s `failsLeaving` s + context "when stream is emtpy" $ + it "signals correct parse error" $ + property $ \a b -> do + let p = char a <|> (char b *> char a) + prs p "" `shouldFailWith` err posI (ueof <> etok a <> etok b) + it "associativity of fold over alternatives should not matter" $ do + let p = asum [empty, string ">>>", empty, return "foo"] "bar" + p' = bsum [empty, string ">>>", empty, return "foo"] "bar" + bsum = foldl (<|>) empty + s = ">>" + prs p s `shouldBe` prs p' s + + describe "many" $ do + context "when stream begins with things argument of many parses" $ + it "they are parsed" $ + property $ \a' b' c' -> do + let [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'a') + s = abcRow a b c + prs p s `shouldParse` replicate a 'a' + prs' p s `succeedsLeaving` drop a s + context "when stream does not begin with thing argument of many parses" $ + it "does nothing" $ + property $ \a' b' c' -> do + let [a,b,c] = getNonNegative <$> [a',b',c'] + p = many (char 'd') + s = abcRow a b c + prs p s `shouldParse` "" + prs' p s `succeedsLeaving` s + context "when stream is empty" $ + it "succeeds parsing nothing" $ do + let p = many (char 'a') + prs p "" `shouldParse` "" + context "when there are two many combinators in a row that parse nothing" $ + it "accumulated hints are reflected in parse error" $ do + let p = many (char 'a') *> many (char 'b') *> eof + prs p "c" `shouldFailWith` err posI + (utok 'c' <> etok 'a' <> etok 'b' <> eeof) + + describe "some" $ do + context "when stream begins with things argument of some parses" $ + it "they are parsed" $ + property $ \a' b' c' -> do + let a = getPositive a' + [b,c] = getNonNegative <$> [b',c'] + p = some (char 'a') + s = abcRow a b c + prs p s `shouldParse` replicate a 'a' + prs' p s `succeedsLeaving` drop a s + context "when stream does not begin with thing argument of some parses" $ + it "signals correct parse error" $ + property $ \a' b' c' -> do + let [a,b,c] = getNonNegative <$> [a',b',c'] + p = some (char 'd') + s = abcRow a b c ++ "g" + prs p s `shouldFailWith` err posI (utok (head s) <> etok 'd') + prs' p s `failsLeaving` s + context "when stream is empty" $ + it "signals correct parse error" $ + property $ \ch -> do + let p = some (char ch) + prs p "" `shouldFailWith` err posI (ueof <> etok ch) + context "optional" $ do + context "when stream begins with that optional thing" $ + it "parses it" $ + property $ \a b -> do + let p = optional (char a) <* char b + s = [a,b] + prs p s `shouldParse` Just a + prs' p s `succeedsLeaving` "" + context "when stream does not begin with that optional thing" $ + it "succeeds parsing nothing" $ + property $ \a b -> a /= b ==> do + let p = optional (char a) <* char b + s = [b] + prs p s `shouldParse` Nothing + prs' p s `succeedsLeaving` "" + context "when stream is empty" $ + it "succeeds parsing nothing" $ + property $ \a -> do + let p = optional (char a) + prs p "" `shouldParse` Nothing + + describe "ParsecT Monad instance" $ do + it "satisfies left identity law" $ + property $ \a k' -> do + let k = return . (+ k') + p = return (a :: Int) >>= k + prs p "" `shouldBe` prs (k a) "" + it "satisfies right identity law" $ + property $ \a -> do + let m = return (a :: Int) + p = m >>= return + prs p "" `shouldBe` prs m "" + it "satisfies associativity law" $ + property $ \m' k' h' -> do + let m = return (m' :: Int) + k = return . (+ k') + h = return . (* h') + p = m >>= (\x -> k x >>= h) + p' = (m >>= k) >>= h + prs p "" `shouldBe` prs p' "" + it "fails signals correct parse error" $ + property $ \msg -> do + let p = fail msg :: Parsec Dec String () + prs p "" `shouldFailWith` err posI (cstm (DecFail msg)) + it "pure is the same as return" $ + property $ \n -> + prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" + it "(<*>) is the same as ap" $ + property $ \m' k' -> do + let m = return (m' :: Int) + k = return (+ k') + prs (k <*> m) "" `shouldBe` prs (k `ap` m) "" + + describe "ParsecT MonadIO instance" $ + it "liftIO works" $ + property $ \n -> do + let p = liftIO (return n) :: ParsecT Dec String IO Integer + runParserT p "" "" `shouldReturn` Right n + + describe "ParsecT MonadReader instance" $ do + + describe "ask" $ + it "returns correct value of context" $ + property $ \n -> do + let p = ask :: ParsecT Dec String (Reader Integer) Integer + runReader (runParserT p "" "") n `shouldBe` Right n + + describe "local" $ + it "modifies reader context correctly" $ + property $ \n k -> do + let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer + runReader (runParserT p "" "") n `shouldBe` Right (n + k) + + describe "ParsecT MonadState instance" $ do + + describe "get" $ + it "returns correct state value" $ + property $ \n -> do + let p = L.get :: ParsecT Dec String (L.State Integer) Integer + L.evalState (runParserT p "" "") n `shouldBe` Right n + describe "put" $ + it "replaces state value" $ + property $ \a b -> do + let p = L.put b :: ParsecT Dec String (L.State Integer) () + L.execState (runParserT p "" "") a `shouldBe` b + + describe "ParsecT MonadCont instance" $ + + describe "callCC" $ + it "works properly" $ + property $ \a b -> do + let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer + p = callCC $ \e -> when (a > b) (e a) >> return b + runCont (runParserT p "" "") id `shouldBe` Right (max a b) + + describe "ParsecT MonadError instance" $ do + + describe "throwError" $ + it "throws the error" $ + property $ \a b -> do + let p :: ParsecT Dec String (Except Integer) Integer + p = throwError a >> return b + runExcept (runParserT p "" "") `shouldBe` Left a + + describe "catchError" $ + it "catches the error" $ + property $ \a b -> do + let p :: ParsecT Dec String (Except Integer) Integer + p = (throwError a >> return b) `catchError` handler + handler e = return (e + b) + runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b) + + describe "primitive combinators" $ do + + describe "unexpected" $ + it "signals correct parse error" $ + property $ \item -> do + let p :: MonadParsec Dec String m => m () + p = void (unexpected item) + grs p "" (`shouldFailWith` ParseError + { errorPos = posI + , errorUnexpected = E.singleton item + , errorExpected = E.empty + , errorCustom = E.empty }) + + describe "failure" $ + it "signals correct parse error" $ + property $ \us ps xs -> do + let p :: MonadParsec Dec String m => m () + p = void (failure us ps xs) + grs p "" (`shouldFailWith` ParseError + { errorPos = posI + , errorUnexpected = us + , errorExpected = ps + , errorCustom = xs }) + + describe "label" $ do + context "when inner parser succeeds consuming input" $ do + context "inner parser does not produce any hints" $ + it "collection of hints remains empty" $ + property $ \lbl a -> not (null lbl) ==> do + let p :: MonadParsec Dec String m => m Char + p = label lbl (char a) <* empty + s = [a] + grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty) + grs' p s (`failsLeaving` "") + context "inner parser produces hints" $ + it "replaces the last hint with “rest of