mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-12-25 01:07:57 +03:00
Merge pull request #138 from mrkkrp/migrate-to-hspec
Re-write the tests with Hspec and more
This commit is contained in:
commit
735776519c
@ -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";
|
||||
|
14
CHANGELOG.md
14
CHANGELOG.md
@ -9,6 +9,20 @@
|
||||
* Exposed `parseErrorTextPretty` function in `Text.Megaparsec.Error` to
|
||||
allow render `ParseError`s without stack of source positions.
|
||||
|
||||
* Eliminated the `old-tests` test suite — Parsec legacy. The cases that are
|
||||
not already *obviously* covered in the main test suite were included into
|
||||
it.
|
||||
|
||||
* Added `Arbitrary` instances for the following data types: `Pos`,
|
||||
`SourcePos`, `ErrorItem`, `Dec`, `ParseError` and `State`. This should
|
||||
make testing easier without the need to add orphan instances every time.
|
||||
The drawback is that we start to depend on `QuickCheck`, but that's a fair
|
||||
price.
|
||||
|
||||
* The test suite now uses the combination of Hspec and the
|
||||
`hpesc-megaparsec` package, which also improved the latter (that package
|
||||
is the recommended way to test Megaparsec parsers).
|
||||
|
||||
## Megaparsec 5.0.1
|
||||
|
||||
* Derived `NFData` instances for `Pos`, `InvalidPosException`, `SourcePos`,
|
||||
|
@ -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'.
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
--
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -1 +1 @@
|
||||
((test "--test-arguments=--threads=2 --maximum-generated-tests=1000"))
|
||||
((test "--test-arguments=--qc-max-success=1000"))
|
||||
|
@ -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 ]
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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 ">>>") ]]
|
@ -1,6 +0,0 @@
|
||||
import Test.Framework
|
||||
|
||||
import Bugs (bugs)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain [testGroup "Bugs" bugs]
|
@ -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 _ -> []
|
@ -1,3 +1,3 @@
|
||||
resolver: lts-6.11
|
||||
resolver: lts-6.15
|
||||
packages:
|
||||
- '.'
|
||||
|
246
tests/Char.hs
246
tests/Char.hs
@ -1,246 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec's character parsers.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Char (tests) where
|
||||
|
||||
import Data.Char
|
||||
import Data.List (findIndex, isPrefixOf)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.QuickCheck
|
||||
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Error
|
||||
|
||||
import Util
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
|
||||
tests :: Test
|
||||
tests = testGroup "Character parsers"
|
||||
[ testProperty "newline" prop_newline
|
||||
, testProperty "crlf" prop_crlf
|
||||
, testProperty "eol" prop_eol
|
||||
, testProperty "tab" prop_tab
|
||||
, testProperty "space" prop_space
|
||||
, testProperty "controlChar" prop_controlChar
|
||||
, testProperty "spaceChar" prop_spaceChar
|
||||
, testProperty "upperChar" prop_upperChar
|
||||
, testProperty "lowerChar" prop_lowerChar
|
||||
, testProperty "letterChar" prop_letterChar
|
||||
, testProperty "alphaNumChar" prop_alphaNumChar
|
||||
, testProperty "printChar" prop_printChar
|
||||
, testProperty "digitChar" prop_digitChar
|
||||
, testProperty "hexDigitChar" prop_hexDigitChar
|
||||
, testProperty "octDigitChar" prop_octDigitChar
|
||||
, testProperty "markChar" prop_markChar
|
||||
, testProperty "numberChar" prop_numberChar
|
||||
, testProperty "punctuationChar" prop_punctuationChar
|
||||
, testProperty "symbolChar" prop_symbolChar
|
||||
, testProperty "separatorChar" prop_separatorChar
|
||||
, testProperty "asciiChar" prop_asciiChar
|
||||
, testProperty "latin1Char" prop_latin1Char
|
||||
, testProperty "charCategory" prop_charCategory
|
||||
, testProperty "char" prop_char
|
||||
, testProperty "char'" prop_char'
|
||||
, testProperty "anyChar" prop_anyChar
|
||||
, testProperty "oneOf" prop_oneOf
|
||||
, testProperty "oneOf'" prop_oneOf'
|
||||
, testProperty "noneOf" prop_noneOf
|
||||
, testProperty "noneOf'" prop_noneOf'
|
||||
, testProperty "string" prop_string
|
||||
, testProperty "string'" prop_string'_0
|
||||
, testProperty "string' (case)" prop_string'_1 ]
|
||||
|
||||
instance Arbitrary GeneralCategory where
|
||||
arbitrary = elements [minBound..maxBound]
|
||||
|
||||
prop_newline :: String -> Property
|
||||
prop_newline = checkChar newline (== '\n') (tkn '\n')
|
||||
|
||||
prop_crlf :: String -> Property
|
||||
prop_crlf = checkString crlf "\r\n" (==)
|
||||
|
||||
prop_eol :: String -> Property
|
||||
prop_eol s = checkParser eol r s
|
||||
where h = head s
|
||||
r | s == "\n" = Right "\n"
|
||||
| s == "\r\n" = Right "\r\n"
|
||||
| null s = posErr 0 s [ueof, elabel "end of line"]
|
||||
| h == '\n' = posErr 1 s [utok (s !! 1), eeof]
|
||||
| h /= '\r' = posErr 0 s [utok h, elabel "end of line"]
|
||||
| "\r\n" `isPrefixOf` s = posErr 2 s [utok (s !! 2), eeof]
|
||||
| otherwise = posErr 0 s [ utoks (take 2 s)
|
||||
, utok '\r'
|
||||
, elabel "end of line" ]
|
||||
|
||||
prop_tab :: String -> Property
|
||||
prop_tab = checkChar tab (== '\t') (tkn '\t')
|
||||
|
||||
prop_space :: String -> Property
|
||||
prop_space s = checkParser space r s
|
||||
where r = case findIndex (not . isSpace) s of
|
||||
Just x ->
|
||||
let ch = s !! x
|
||||
in posErr x s
|
||||
[ utok ch
|
||||
, utok ch
|
||||
, elabel "white space"
|
||||
, eeof ]
|
||||
Nothing -> Right ()
|
||||
|
||||
prop_controlChar :: String -> Property
|
||||
prop_controlChar = checkChar controlChar isControl (lbl "control character")
|
||||
|
||||
prop_spaceChar :: String -> Property
|
||||
prop_spaceChar = checkChar spaceChar isSpace (lbl "white space")
|
||||
|
||||
prop_upperChar :: String -> Property
|
||||
prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter")
|
||||
|
||||
prop_lowerChar :: String -> Property
|
||||
prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter")
|
||||
|
||||
prop_letterChar :: String -> Property
|
||||
prop_letterChar = checkChar letterChar isAlpha (lbl "letter")
|
||||
|
||||
prop_alphaNumChar :: String -> Property
|
||||
prop_alphaNumChar = checkChar alphaNumChar isAlphaNum
|
||||
(lbl "alphanumeric character")
|
||||
|
||||
prop_printChar :: String -> Property
|
||||
prop_printChar = checkChar printChar isPrint (lbl "printable character")
|
||||
|
||||
prop_digitChar :: String -> Property
|
||||
prop_digitChar = checkChar digitChar isDigit (lbl "digit")
|
||||
|
||||
prop_octDigitChar :: String -> Property
|
||||
prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit")
|
||||
|
||||
prop_hexDigitChar :: String -> Property
|
||||
prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit")
|
||||
|
||||
prop_markChar :: String -> Property
|
||||
prop_markChar = checkChar markChar isMark (lbl "mark character")
|
||||
|
||||
prop_numberChar :: String -> Property
|
||||
prop_numberChar = checkChar numberChar isNumber (lbl "numeric character")
|
||||
|
||||
prop_punctuationChar :: String -> Property
|
||||
prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation")
|
||||
|
||||
prop_symbolChar :: String -> Property
|
||||
prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol")
|
||||
|
||||
prop_separatorChar :: String -> Property
|
||||
prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator")
|
||||
|
||||
prop_asciiChar :: String -> Property
|
||||
prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character")
|
||||
|
||||
prop_latin1Char :: String -> Property
|
||||
prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character")
|
||||
|
||||
prop_charCategory :: GeneralCategory -> String -> Property
|
||||
prop_charCategory cat = checkChar (charCategory cat) p (lbl $ categoryName cat)
|
||||
where p c = generalCategory c == cat
|
||||
|
||||
prop_char :: Char -> String -> Property
|
||||
prop_char c = checkChar (char c) (== c) (tkn c)
|
||||
|
||||
prop_char' :: Char -> String -> Property
|
||||
prop_char' c s = checkParser (char' c) r s
|
||||
where h = head s
|
||||
l | isLower c = [c, toUpper c]
|
||||
| isUpper c = [c, toLower c]
|
||||
| otherwise = [c]
|
||||
r | null s = posErr 0 s $ ueof : (etok <$> l)
|
||||
| length s == 1 && (h `elemi` l) = Right h
|
||||
| h `notElemi` l = posErr 0 s $ utok h : (etok <$> l)
|
||||
| otherwise = posErr 1 s [utok (s !! 1), eeof]
|
||||
|
||||
prop_anyChar :: String -> Property
|
||||
prop_anyChar = checkChar anyChar (const True) (lbl "character")
|
||||
|
||||
prop_oneOf :: String -> String -> Property
|
||||
prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing
|
||||
|
||||
prop_oneOf' :: String -> String -> Property
|
||||
prop_oneOf' a = checkChar (oneOf' a) (`elemi` a) Nothing
|
||||
|
||||
prop_noneOf :: String -> String -> Property
|
||||
prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing
|
||||
|
||||
prop_noneOf' :: String -> String -> Property
|
||||
prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing
|
||||
|
||||
prop_string :: String -> String -> Property
|
||||
prop_string a = checkString (string a) a (==)
|
||||
|
||||
prop_string'_0 :: String -> String -> Property
|
||||
prop_string'_0 a = checkString (string' a) a casei
|
||||
|
||||
-- | Randomly change the case in the given string.
|
||||
|
||||
fuzzyCase :: String -> Gen String
|
||||
fuzzyCase s = zipWith f s <$> vector (length s)
|
||||
where f k True = if isLower k then toUpper k else toLower k
|
||||
f k False = k
|
||||
|
||||
prop_string'_1 :: String -> Property
|
||||
prop_string'_1 a = forAll (fuzzyCase a) $ \s ->
|
||||
checkString (string' a) a casei s
|
||||
|
||||
-- | Case-insensitive equality test for characters.
|
||||
|
||||
casei :: Char -> Char -> Bool
|
||||
casei x y = toLower x == toLower y
|
||||
|
||||
-- | Case-insensitive 'elem'.
|
||||
|
||||
elemi :: Char -> String -> Bool
|
||||
elemi c = any (casei c)
|
||||
|
||||
-- | Case-insensitive 'notElem'.
|
||||
|
||||
notElemi :: Char -> String -> Bool
|
||||
notElemi c = not . elemi c
|
||||
|
||||
tkn :: Char -> Maybe (ErrorItem Char)
|
||||
tkn = Just . Tokens . (:|[])
|
||||
|
||||
lbl :: String -> Maybe (ErrorItem Char)
|
||||
lbl = Just . Label . NE.fromList
|
@ -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
|
152
tests/Error.hs
152
tests/Error.hs
@ -1,152 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec's parse errors.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Error (tests) where
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.List (isInfixOf)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Set (Set)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Set as E
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.HUnit (Assertion, (@?=))
|
||||
import Test.QuickCheck
|
||||
|
||||
import Text.Megaparsec.Error
|
||||
import Text.Megaparsec.Pos
|
||||
|
||||
import Util ()
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Data.Foldable (Foldable, all)
|
||||
import Data.Monoid (mempty)
|
||||
import Prelude hiding (all)
|
||||
#endif
|
||||
|
||||
tests :: Test
|
||||
tests = testGroup "Parse errors"
|
||||
[ testProperty "monoid left identity" prop_monoid_left_id
|
||||
, testProperty "monoid right identity" prop_monoid_right_id
|
||||
, testProperty "monoid associativity" prop_monoid_assoc
|
||||
, testProperty "consistency of Show/Read" prop_showReadConsistency
|
||||
, testProperty "position of merged error" prop_mergeErrorPos
|
||||
, testProperty "unexpected items in merged error" prop_mergeErrorUnexpected
|
||||
, testProperty "expected items in merged error" prop_mergeErrorExpected
|
||||
, testProperty "custom items in merged error" prop_mergeErrorCustom
|
||||
, testCase "showTokens (String instance)" case_showTokens
|
||||
, testCase "rendering of unknown parse error" case_ppUnknownError
|
||||
, testProperty "source position in rendered error" prop_ppSourcePos
|
||||
, testProperty "unexpected items in rendered error" prop_ppUnexpected
|
||||
, testProperty "expected items in rendered error" prop_ppExpected
|
||||
, testProperty "custom data in rendered error" prop_ppCustom ]
|
||||
|
||||
type PE = ParseError Char Dec
|
||||
|
||||
prop_monoid_left_id :: PE -> Property
|
||||
prop_monoid_left_id x = mempty <> x === x .&&.
|
||||
mempty { errorPos = errorPos x } <> x === x
|
||||
|
||||
prop_monoid_right_id :: PE -> Property
|
||||
prop_monoid_right_id x = x <> mempty === x .&&.
|
||||
mempty { errorPos = errorPos x } <> x === x
|
||||
|
||||
prop_monoid_assoc :: PE -> PE -> PE -> Property
|
||||
prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z)
|
||||
|
||||
prop_showReadConsistency :: PE -> Property
|
||||
prop_showReadConsistency x = read (show x) === x
|
||||
|
||||
prop_mergeErrorPos :: PE -> PE -> Property
|
||||
prop_mergeErrorPos e1 e2 =
|
||||
errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2)
|
||||
|
||||
prop_mergeErrorUnexpected :: PE -> PE -> Property
|
||||
prop_mergeErrorUnexpected = checkMergedItems errorUnexpected
|
||||
|
||||
prop_mergeErrorExpected :: PE -> PE -> Property
|
||||
prop_mergeErrorExpected = checkMergedItems errorExpected
|
||||
|
||||
prop_mergeErrorCustom :: PE -> PE -> Property
|
||||
prop_mergeErrorCustom = checkMergedItems errorCustom
|
||||
|
||||
checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property
|
||||
checkMergedItems f e1 e2 = f (e1 <> e2) === r
|
||||
where r = case (compare `on` errorPos) e1 e2 of
|
||||
LT -> f e2
|
||||
EQ -> (E.union `on` f) e1 e2
|
||||
GT -> f e1
|
||||
|
||||
case_showTokens :: Assertion
|
||||
case_showTokens = mapM_ (\(x,y) -> showTokens (NE.fromList x) @?= y)
|
||||
[ ("\r\n", "crlf newline")
|
||||
, ("\0", "null")
|
||||
, ("\a", "bell")
|
||||
, ("\b", "backspace")
|
||||
, ("\t", "tab")
|
||||
, ("\n", "newline")
|
||||
, ("\v", "vertical tab")
|
||||
, ("\f", "form feed")
|
||||
, ("\r", "carriage return")
|
||||
, (" ", "space")
|
||||
, ("a", "'a'")
|
||||
, ("foo", "\"foo\"") ]
|
||||
|
||||
case_ppUnknownError :: Assertion
|
||||
case_ppUnknownError =
|
||||
parseErrorPretty (err :: PE) @?= "1:1:\nunknown parse error\n"
|
||||
where
|
||||
err = ParseError
|
||||
{ errorPos = initialPos "" :| []
|
||||
, errorUnexpected = E.empty
|
||||
, errorExpected = E.empty
|
||||
, errorCustom = E.empty }
|
||||
|
||||
prop_ppSourcePos :: PE -> Property
|
||||
prop_ppSourcePos = checkPresence errorPos sourcePosPretty
|
||||
|
||||
prop_ppUnexpected :: PE -> Property
|
||||
prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent
|
||||
|
||||
prop_ppExpected :: PE -> Property
|
||||
prop_ppExpected = checkPresence errorExpected showErrorComponent
|
||||
|
||||
prop_ppCustom :: PE -> Property
|
||||
prop_ppCustom = checkPresence errorCustom showErrorComponent
|
||||
|
||||
checkPresence :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property
|
||||
checkPresence g r e = property (all f (g e))
|
||||
where rendered = parseErrorPretty e
|
||||
f x = r x `isInfixOf` rendered
|
409
tests/Lexer.hs
409
tests/Lexer.hs
@ -1,409 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec's lexer.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Lexer (tests) where
|
||||
|
||||
import Control.Applicative (empty)
|
||||
import Control.Monad (void)
|
||||
import Data.Char
|
||||
( readLitChar
|
||||
, showLitChar
|
||||
, isDigit
|
||||
, isAlphaNum
|
||||
, isSpace
|
||||
, toLower )
|
||||
import Data.List (findIndices, isInfixOf, find)
|
||||
import Data.Maybe
|
||||
import Data.Scientific (fromFloatDigits)
|
||||
import Numeric (showInt, showHex, showOct, showSigned)
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.HUnit (Assertion)
|
||||
import Test.QuickCheck
|
||||
|
||||
import Text.Megaparsec.Error
|
||||
import Text.Megaparsec.Lexer
|
||||
import Text.Megaparsec.Pos
|
||||
import Text.Megaparsec.Prim
|
||||
import Text.Megaparsec.String
|
||||
import qualified Text.Megaparsec.Char as C
|
||||
|
||||
import Util
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>), (<*), (<*>), (<$))
|
||||
#endif
|
||||
|
||||
tests :: Test
|
||||
tests = testGroup "Lexer"
|
||||
[ testProperty "space combinator" prop_space
|
||||
, testProperty "symbol combinator" prop_symbol
|
||||
, testProperty "symbol' combinator" prop_symbol'
|
||||
, testCase "case_skipLineCommentEof" case_skipLineCommentEof
|
||||
, testCase "skipBlockCommentNested" case_skipBlockCommentNested
|
||||
, testProperty "indentLevel" prop_indentLevel
|
||||
, testProperty "incorrectIndent" prop_incorrectIndent
|
||||
, testProperty "indentGuard combinator" prop_indentGuard
|
||||
, testProperty "nonIndented combinator" prop_nonIndented
|
||||
, testProperty "indentBlock combinator" prop_indentBlock
|
||||
, testProperty "indentBlock (many)" prop_indentMany
|
||||
, testProperty "lineFold" prop_lineFold
|
||||
, testProperty "charLiteral" prop_charLiteral
|
||||
, testProperty "integer" prop_integer
|
||||
, testProperty "decimal" prop_decimal
|
||||
, testProperty "hexadecimal" prop_hexadecimal
|
||||
, testProperty "octal" prop_octal
|
||||
, testProperty "float 0" prop_float_0
|
||||
, testProperty "float 1" prop_float_1
|
||||
, testProperty "number 0" prop_number_0
|
||||
, testProperty "number 1" prop_number_1
|
||||
, testProperty "number 2 (signed)" prop_number_2
|
||||
, testProperty "signed" prop_signed ]
|
||||
|
||||
-- White space
|
||||
|
||||
mkWhiteSpace :: Gen String
|
||||
mkWhiteSpace = concat <$> listOf whiteUnit
|
||||
where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]
|
||||
|
||||
mkSymbol :: Gen String
|
||||
mkSymbol = (++) <$> symbolName <*> whiteChars
|
||||
|
||||
mkInterspace :: String -> Int -> Gen String
|
||||
mkInterspace x n = oneof [si, mkIndent x n]
|
||||
where si = (++ x) <$> listOf (elements " \t")
|
||||
|
||||
mkIndent :: String -> Int -> Gen String
|
||||
mkIndent x n = (++) <$> mkIndent' x n <*> eol
|
||||
where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]
|
||||
|
||||
mkIndent' :: String -> Int -> Gen String
|
||||
mkIndent' x n = concat <$> sequence [spc, sym, tra]
|
||||
where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]
|
||||
tra = listOf itm
|
||||
itm = elements " \t"
|
||||
sym = return x
|
||||
|
||||
whiteChars :: Gen String
|
||||
whiteChars = listOf (elements "\t\n ")
|
||||
|
||||
whiteLine :: Gen String
|
||||
whiteLine = commentOut <$> arbitrary `suchThat` goodEnough
|
||||
where commentOut x = "//" ++ x ++ "\n"
|
||||
goodEnough x = '\n' `notElem` x
|
||||
|
||||
whiteBlock :: Gen String
|
||||
whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough
|
||||
where commentOut x = "/*" ++ x ++ "*/"
|
||||
goodEnough x = not $ "*/" `isInfixOf` x
|
||||
|
||||
symbolName :: Gen String
|
||||
symbolName = listOf $ arbitrary `suchThat` isAlphaNum
|
||||
|
||||
sc :: Parser ()
|
||||
sc = space (void $ C.oneOf " \t") empty empty
|
||||
|
||||
scn :: Parser ()
|
||||
scn = space (void C.spaceChar) l b
|
||||
where l = skipLineComment "//"
|
||||
b = skipBlockComment "/*" "*/"
|
||||
|
||||
prop_space :: Property
|
||||
prop_space = forAll mkWhiteSpace (checkParser p r)
|
||||
where p = scn
|
||||
r = Right ()
|
||||
|
||||
prop_symbol :: Maybe Char -> Property
|
||||
prop_symbol t = forAll mkSymbol $ \s ->
|
||||
parseSymbol (symbol scn) id s t
|
||||
|
||||
prop_symbol' :: Maybe Char -> Property
|
||||
prop_symbol' t = forAll mkSymbol $ \s ->
|
||||
parseSymbol (symbol' scn) (fmap toLower) s t
|
||||
|
||||
parseSymbol
|
||||
:: (String -> Parser String)
|
||||
-> (String -> String)
|
||||
-> String
|
||||
-> Maybe Char
|
||||
-> Property
|
||||
parseSymbol p' f s' t = checkParser p r s
|
||||
where p = p' (f g)
|
||||
r | g == s || isSpace (last s) = Right g
|
||||
| otherwise = posErr (length s - 1) s [utok (last s), eeof]
|
||||
g = takeWhile (not . isSpace) s
|
||||
s = s' ++ maybeToList t
|
||||
|
||||
case_skipLineCommentEof :: Assertion
|
||||
case_skipLineCommentEof = checkCase p r s
|
||||
where p = space (void C.spaceChar) (skipLineComment "//") empty <* eof
|
||||
r = Right ()
|
||||
s = " // this line comment doesn't have a newline at the end "
|
||||
|
||||
case_skipBlockCommentNested :: Assertion
|
||||
case_skipBlockCommentNested = checkCase p r s
|
||||
where p = space (void C.spaceChar) empty
|
||||
(skipBlockCommentNested "/*" "*/") <* eof
|
||||
r = Right ()
|
||||
s = " /* foo bar /* baz */ quux */ "
|
||||
|
||||
-- Indentation
|
||||
|
||||
prop_indentLevel :: SourcePos -> Property
|
||||
prop_indentLevel pos = p /=\ sourceColumn pos
|
||||
where p = setPosition pos >> indentLevel
|
||||
|
||||
prop_incorrectIndent :: Ordering -> Pos -> Pos -> Property
|
||||
prop_incorrectIndent ord ref actual = checkParser p r s
|
||||
where p = incorrectIndent ord ref actual :: Parser ()
|
||||
r = posErr 0 s (ii ord ref actual)
|
||||
s = ""
|
||||
|
||||
prop_indentGuard :: NonNegative (Small Int) -> Property
|
||||
prop_indentGuard n =
|
||||
forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) ->
|
||||
let r | col0 <= pos1 = posErr 0 s (ii GT pos1 col0)
|
||||
| col1 /= col0 = posErr (getIndent l1 + g 1) s (ii EQ col0 col1)
|
||||
| col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2)
|
||||
| otherwise = Right ()
|
||||
(col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
|
||||
fragments = [l0,l1,l2]
|
||||
g x = sum (length <$> take x fragments)
|
||||
s = concat fragments
|
||||
in checkParser p r s
|
||||
where mki = mkIndent sbla (getSmall $ getNonNegative n)
|
||||
p = ip GT pos1 >>=
|
||||
\x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn
|
||||
ip = indentGuard scn
|
||||
sp = void (symbol sc sbla <* C.eol)
|
||||
|
||||
prop_nonIndented :: Property
|
||||
prop_nonIndented = forAll (mkIndent sbla 0) $ \s ->
|
||||
let i = getIndent s
|
||||
r | i == 0 = Right sbla
|
||||
| otherwise = posErr i s (ii EQ pos1 (getCol s))
|
||||
in checkParser p r s
|
||||
where p = nonIndented scn (symbol scn sbla)
|
||||
|
||||
prop_indentBlock :: Maybe (Positive (Small Int)) -> Property
|
||||
prop_indentBlock mn'' = forAll mkBlock $ \(l0,l1,l2,l3,l4) ->
|
||||
let r | col1 <= col0 =
|
||||
posErr (getIndent l1 + g 1) s [utok (head sblb), eeof]
|
||||
| isJust mn && col1 /= ib' =
|
||||
posErr (getIndent l1 + g 1) s (ii EQ ib' col1)
|
||||
| col2 <= col1 =
|
||||
posErr (getIndent l2 + g 2) s (ii GT col1 col2)
|
||||
| col3 == col2 =
|
||||
posErr (getIndent l3 + g 3) s [utok (head sblb), etoks sblc]
|
||||
| col3 <= col0 =
|
||||
posErr (getIndent l3 + g 3) s [utok (head sblb), eeof]
|
||||
| col3 < col1 =
|
||||
posErr (getIndent l3 + g 3) s (ii EQ col1 col3)
|
||||
| col3 > col1 =
|
||||
posErr (getIndent l3 + g 3) s (ii EQ col2 col3)
|
||||
| col4 <= col3 =
|
||||
posErr (getIndent l4 + g 4) s (ii GT col3 col4)
|
||||
| otherwise = Right (sbla, [(sblb, [sblc]), (sblb, [sblc])])
|
||||
(col0, col1, col2, col3, col4) =
|
||||
(getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)
|
||||
fragments = [l0,l1,l2,l3,l4]
|
||||
g x = sum (length <$> take x fragments)
|
||||
s = concat fragments
|
||||
in checkParser p r s
|
||||
where mkBlock = do
|
||||
l0 <- mkIndent sbla 0
|
||||
l1 <- mkIndent sblb ib
|
||||
l2 <- mkIndent sblc (ib + 2)
|
||||
l3 <- mkIndent sblb ib
|
||||
l4 <- mkIndent' sblc (ib + 2)
|
||||
return (l0,l1,l2,l3,l4)
|
||||
p = lvla
|
||||
lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla
|
||||
lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb
|
||||
lvlc = indentBlock scn $ IndentNone sblc <$ b sblc
|
||||
b = symbol sc
|
||||
l x = return . (x,)
|
||||
mn' = getSmall . getPositive <$> mn''
|
||||
mn = unsafePos . fromIntegral <$> mn'
|
||||
ib = fromMaybe 2 mn'
|
||||
ib' = unsafePos (fromIntegral ib)
|
||||
|
||||
prop_indentMany :: Property
|
||||
prop_indentMany = forAll (mkIndent sbla 0) (checkParser p r)
|
||||
where r = Right (sbla, [])
|
||||
p = lvla
|
||||
lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla
|
||||
lvlb = b sblb
|
||||
b = symbol sc
|
||||
l x = return . (x,)
|
||||
|
||||
prop_lineFold :: Property
|
||||
prop_lineFold = forAll mkFold $ \(l0,l1,l2) ->
|
||||
let r | end0 && col1 <= col0 =
|
||||
posErr (getIndent l1 + g 1) s (ii GT col0 col1)
|
||||
| end1 && col2 <= col0 =
|
||||
posErr (getIndent l2 + g 2) s (ii GT col0 col2)
|
||||
| otherwise = Right (sbla, sblb, sblc)
|
||||
(col0, col1, col2) = (getCol l0, getCol l1, getCol l2)
|
||||
(end0, end1) = (getEnd l0, getEnd l1)
|
||||
fragments = [l0,l1,l2]
|
||||
g x = sum (length <$> take x fragments)
|
||||
s = concat fragments
|
||||
in checkParser p r s
|
||||
where
|
||||
mkFold = do
|
||||
l0 <- mkInterspace sbla 0
|
||||
l1 <- mkInterspace sblb 1
|
||||
l2 <- mkInterspace sblc 1
|
||||
return (l0,l1,l2)
|
||||
p = lineFold scn $ \sc' -> do
|
||||
a <- symbol sc' sbla
|
||||
b <- symbol sc' sblb
|
||||
c <- symbol scn sblc
|
||||
return (a, b, c)
|
||||
getEnd x = last x == '\n'
|
||||
|
||||
getIndent :: String -> Int
|
||||
getIndent = length . takeWhile isSpace
|
||||
|
||||
getCol :: String -> Pos
|
||||
getCol x = sourceColumn .
|
||||
updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x
|
||||
|
||||
sbla, sblb, sblc :: String
|
||||
sbla = "aaa"
|
||||
sblb = "bbb"
|
||||
sblc = "ccc"
|
||||
|
||||
ii :: Ordering -> Pos -> Pos -> [EC]
|
||||
ii ord ref actual = [cstm (DecIndentation ord ref actual)]
|
||||
|
||||
pos1 :: Pos
|
||||
pos1 = unsafePos 1
|
||||
|
||||
-- Character and string literals
|
||||
|
||||
prop_charLiteral :: String -> Bool -> Property
|
||||
prop_charLiteral t i = checkParser charLiteral r s
|
||||
where b = listToMaybe $ readLitChar s
|
||||
(h, g) = fromJust b
|
||||
r | isNothing b = posErr 0 s $ elabel "literal character" :
|
||||
[ if null s then ueof else utok (head s) ]
|
||||
| null g = Right h
|
||||
| otherwise = posErr l s [utok (head g), eeof]
|
||||
l = length s - length g
|
||||
s = if null t || i then t else showLitChar (head t) (tail t)
|
||||
|
||||
-- Numbers
|
||||
|
||||
prop_integer :: NonNegative Integer -> Int -> Property
|
||||
prop_integer n' i = checkParser integer r s
|
||||
where (r, s) = quasiCorrupted n' i showInt "integer"
|
||||
|
||||
prop_decimal :: NonNegative Integer -> Int -> Property
|
||||
prop_decimal n' i = checkParser decimal r s
|
||||
where (r, s) = quasiCorrupted n' i showInt "decimal integer"
|
||||
|
||||
prop_hexadecimal :: NonNegative Integer -> Int -> Property
|
||||
prop_hexadecimal n' i = checkParser hexadecimal r s
|
||||
where (r, s) = quasiCorrupted n' i showHex "hexadecimal integer"
|
||||
|
||||
prop_octal :: NonNegative Integer -> Int -> Property
|
||||
prop_octal n' i = checkParser octal r s
|
||||
where (r, s) = quasiCorrupted n' i showOct "octal integer"
|
||||
|
||||
prop_float_0 :: NonNegative Double -> Property
|
||||
prop_float_0 n' = checkParser float r s
|
||||
where n = getNonNegative n'
|
||||
r = Right n
|
||||
s = show n
|
||||
|
||||
prop_float_1 :: Maybe (NonNegative Integer) -> Property
|
||||
prop_float_1 n' = checkParser float r s
|
||||
where r | isNothing n' = posErr 0 s [ueof, elabel "floating point number"]
|
||||
| otherwise = posErr (length s) s
|
||||
[ueof, etok '.', etok 'E', etok 'e', elabel "digit"]
|
||||
s = maybe "" (show . getNonNegative) n'
|
||||
|
||||
prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property
|
||||
prop_number_0 n' = checkParser number r s
|
||||
where r = Right $ case n' of
|
||||
Left x -> fromIntegral . getNonNegative $ x
|
||||
Right x -> fromFloatDigits . getNonNegative $ x
|
||||
s = either (show . getNonNegative) (show . getNonNegative) n'
|
||||
|
||||
prop_number_1 :: Property
|
||||
prop_number_1 = checkParser number r s
|
||||
where r = posErr 0 s [ueof, elabel "number"]
|
||||
s = ""
|
||||
|
||||
prop_number_2 :: Either Integer Double -> Property
|
||||
prop_number_2 n = checkParser p r s
|
||||
where p = signed (hidden C.space) number
|
||||
r = Right $ case n of
|
||||
Left x -> fromIntegral x
|
||||
Right x -> fromFloatDigits x
|
||||
s = either show show n
|
||||
|
||||
prop_signed :: Integer -> Int -> Bool -> Property
|
||||
prop_signed n i plus = checkParser p r s
|
||||
where p = signed (hidden C.space) integer
|
||||
r | i > length z = Right n
|
||||
| otherwise = posErr i s $ utok '?' :
|
||||
(if i <= 0 then [etok '+', etok '-'] else []) ++
|
||||
[elabel $ if isNothing . find isDigit $ take i s
|
||||
then "integer"
|
||||
else "rest of integer"] ++
|
||||
[eeof | i > head (findIndices isDigit s)]
|
||||
z = let bar = showSigned showInt 0 n ""
|
||||
in if n < 0 || plus then bar else '+' : bar
|
||||
s = if i <= length z then take i z ++ "?" ++ drop i z else z
|
||||
|
||||
quasiCorrupted
|
||||
:: NonNegative Integer
|
||||
-> Int
|
||||
-> (Integer -> String -> String)
|
||||
-> String
|
||||
-> (Either (ParseError Char Dec) Integer, String)
|
||||
quasiCorrupted n' i shower l = (r, s)
|
||||
where n = getNonNegative n'
|
||||
r | i > length z = Right n
|
||||
| otherwise = posErr i s $ utok '?' :
|
||||
[ eeof | i > 0 ] ++
|
||||
[if i <= 0 || null l
|
||||
then elabel l
|
||||
else elabel $ "rest of " ++ l]
|
||||
z = shower n ""
|
||||
s = if i <= length z then take i z ++ "?" ++ drop i z else z
|
@ -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 ]
|
103
tests/Perm.hs
103
tests/Perm.hs
@ -1,103 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec's permutation phrases parsers.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
module Perm (tests) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List (nub, elemIndices)
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.QuickCheck
|
||||
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Lexer (integer)
|
||||
import Text.Megaparsec.Perm
|
||||
|
||||
import Util
|
||||
|
||||
tests :: Test
|
||||
tests = testGroup "Permutation phrases parsers"
|
||||
[ testProperty "permutation parser pure" prop_pure
|
||||
, testProperty "permutation test 0" prop_perm_0
|
||||
, testProperty "combinator (<$$>)" prop_ddcomb ]
|
||||
|
||||
data CharRows = CharRows
|
||||
{ getChars :: (Char, Char, Char)
|
||||
, getInput :: String }
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary CharRows where
|
||||
arbitrary = do
|
||||
chars@(a,b,c) <- arbitrary `suchThat` different
|
||||
an <- arbitrary
|
||||
bn <- arbitrary
|
||||
cn <- arbitrary
|
||||
input <- concat <$> shuffle
|
||||
[ replicate an a
|
||||
, replicate bn b
|
||||
, replicate cn c]
|
||||
return $ CharRows chars input
|
||||
where different (a,b,c) = let l = [a,b,c] in l == nub l
|
||||
|
||||
prop_pure :: Integer -> Property
|
||||
prop_pure n = makePermParser p /=\ n
|
||||
where p = id <$?> (succ n, pure n)
|
||||
|
||||
prop_perm_0 :: String -> Char -> CharRows -> Property
|
||||
prop_perm_0 a' c' v = checkParser (makePermParser p) r s
|
||||
where (a,b,c) = getChars v
|
||||
p = (,,) <$?> (a', some (char a))
|
||||
<||> char b
|
||||
<|?> (c', char c)
|
||||
r | length bis > 1 && (length cis <= 1 || head bis < head cis) =
|
||||
posErr (bis !! 1) s $ [utok b, eeof] ++
|
||||
[etok a | a `notElem` preb] ++
|
||||
[etok c | c `notElem` preb]
|
||||
| length cis > 1 =
|
||||
posErr (cis !! 1) s $ [utok c] ++
|
||||
[etok a | a `notElem` prec] ++
|
||||
[if b `elem` prec then eeof else etok b]
|
||||
| b `notElem` s = posErr (length s) s $ [ueof, etok b] ++
|
||||
[etok a | a `notElem` s || last s == a] ++
|
||||
[etok c | c `notElem` s]
|
||||
| otherwise = Right ( if a `elem` s then filter (== a) s else a'
|
||||
, b
|
||||
, if c `elem` s then c else c' )
|
||||
bis = elemIndices b s
|
||||
preb = take (bis !! 1) s
|
||||
cis = elemIndices c s
|
||||
prec = take (cis !! 1) s
|
||||
s = getInput v
|
||||
|
||||
prop_ddcomb :: NonNegative Integer -> Property
|
||||
prop_ddcomb n' = checkParser (makePermParser p) r s
|
||||
where p = succ <$$> integer
|
||||
r = Right (succ n)
|
||||
n = getNonNegative n'
|
||||
s = show n
|
121
tests/Pos.hs
121
tests/Pos.hs
@ -1,121 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec's textual source positions.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Pos (tests) where
|
||||
|
||||
import Control.Monad.Catch
|
||||
import Data.Function (on)
|
||||
import Data.List (isInfixOf, elemIndices)
|
||||
import Data.Semigroup ((<>))
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.QuickCheck
|
||||
|
||||
import Text.Megaparsec.Pos
|
||||
import Util (updatePosString)
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Data.Word (Word)
|
||||
#endif
|
||||
|
||||
tests :: Test
|
||||
tests = testGroup "Textual source positions"
|
||||
[ testProperty "creation of Pos (mkPos)" prop_mkPos
|
||||
, testProperty "creation of Pos (unsafePos)" prop_unsafePos
|
||||
, testProperty "consistency of Show/Read for Pos" prop_showReadPos
|
||||
, testProperty "Ord instance of Pos" prop_ordPos
|
||||
, testProperty "Semigroup instance of Pos" prop_semigroupPos
|
||||
, testProperty "construction of initial position" prop_initialPos
|
||||
, testProperty "consistency of Show/Read for SourcePos" prop_showReadSourcePos
|
||||
, testProperty "pretty-printing: visible file path" prop_ppFilePath
|
||||
, testProperty "pretty-printing: visible line" prop_ppLine
|
||||
, testProperty "pretty-printing: visible column" prop_ppColumn
|
||||
, testProperty "default updating of source position" prop_defaultUpdatePos ]
|
||||
|
||||
prop_mkPos :: Word -> Property
|
||||
prop_mkPos x' = case mkPos x' of
|
||||
Left e -> fromException e === Just InvalidPosException
|
||||
Right x -> unPos x === x'
|
||||
|
||||
prop_unsafePos :: Positive Word -> Property
|
||||
prop_unsafePos x' = unPos (unsafePos x) === x
|
||||
where x = getPositive x'
|
||||
|
||||
prop_showReadPos :: Pos -> Property
|
||||
prop_showReadPos x = read (show x) === x
|
||||
|
||||
prop_ordPos :: Pos -> Pos -> Property
|
||||
prop_ordPos x y = compare x y === (compare `on` unPos) x y
|
||||
|
||||
prop_semigroupPos :: Pos -> Pos -> Property
|
||||
prop_semigroupPos x y =
|
||||
x <> y === unsafePos (unPos x + unPos y) .&&.
|
||||
unPos (x <> y) === unPos x + unPos y
|
||||
|
||||
prop_initialPos :: String -> Property
|
||||
prop_initialPos fp =
|
||||
sourceName x === fp .&&.
|
||||
sourceLine x === unsafePos 1 .&&.
|
||||
sourceColumn x === unsafePos 1
|
||||
where x = initialPos fp
|
||||
|
||||
prop_showReadSourcePos :: SourcePos -> Property
|
||||
prop_showReadSourcePos x = read (show x) === x
|
||||
|
||||
prop_ppFilePath :: SourcePos -> Property
|
||||
prop_ppFilePath x = property $
|
||||
sourceName x `isInfixOf` sourcePosPretty x
|
||||
|
||||
prop_ppLine :: SourcePos -> Property
|
||||
prop_ppLine x = property $
|
||||
(show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x
|
||||
|
||||
prop_ppColumn :: SourcePos -> Property
|
||||
prop_ppColumn x = property $
|
||||
(show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x
|
||||
|
||||
prop_defaultUpdatePos :: Pos -> SourcePos -> String -> Property
|
||||
prop_defaultUpdatePos w pos "" = updatePosString w pos "" === pos
|
||||
prop_defaultUpdatePos w pos s =
|
||||
sourceName updated === sourceName pos .&&.
|
||||
unPos (sourceLine updated) === unPos (sourceLine pos) + inclines .&&.
|
||||
cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` unPos w == 0))
|
||||
where
|
||||
updated = updatePosString w pos s
|
||||
cols = unPos (sourceColumn updated)
|
||||
newlines = elemIndices '\n' s
|
||||
inclines = fromIntegral (length newlines)
|
||||
total = fromIntegral (length s)
|
||||
mincols =
|
||||
if null newlines
|
||||
then total + unPos (sourceColumn pos)
|
||||
else total - fromIntegral (maximum newlines)
|
1017
tests/Prim.hs
1017
tests/Prim.hs
File diff suppressed because it is too large
Load Diff
11
tests/Spec.hs
Normal file
11
tests/Spec.hs
Normal file
@ -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
|
377
tests/Test/Hspec/Megaparsec.hs
Normal file
377
tests/Test/Hspec/Megaparsec.hs
Normal file
@ -0,0 +1,377 @@
|
||||
-- |
|
||||
-- Module : Test.Hspec.Megaparsec
|
||||
-- Copyright : © 2016 Mark Karpov
|
||||
-- License : BSD 3 clause
|
||||
--
|
||||
-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Utility functions for testing Megaparsec parsers with Hspec.
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Test.Hspec.Megaparsec
|
||||
( -- * Basic expectations
|
||||
shouldParse
|
||||
, parseSatisfies
|
||||
, shouldSucceedOn
|
||||
, shouldFailOn
|
||||
-- * Testing of error messages
|
||||
, shouldFailWith
|
||||
-- * Error message construction
|
||||
-- $errmsg
|
||||
, err
|
||||
, posI
|
||||
, posN
|
||||
, EC
|
||||
, utok
|
||||
, utoks
|
||||
, ulabel
|
||||
, ueof
|
||||
, etok
|
||||
, etoks
|
||||
, elabel
|
||||
, eeof
|
||||
, cstm
|
||||
-- * Incremental parsing
|
||||
, failsLeaving
|
||||
, succeedsLeaving
|
||||
, initialState )
|
||||
where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Data (Data)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Proxy
|
||||
import Data.Semigroup
|
||||
import Data.Set (Set)
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics
|
||||
import Test.Hspec.Expectations
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Pos (defaultTabWidth)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Set as E
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Basic expectations
|
||||
|
||||
-- | Create an expectation by saying what the result should be.
|
||||
--
|
||||
-- > parse letterChar "" "x" `shouldParse` 'x'
|
||||
|
||||
shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a)
|
||||
=> Either (ParseError t e) a
|
||||
-- ^ Result of parsing as returned by function like 'parse'
|
||||
-> a -- ^ Desired result
|
||||
-> Expectation
|
||||
r `shouldParse` v = case r of
|
||||
Left e -> expectationFailure $ "expected: " ++ show v ++
|
||||
"\nbut parsing failed with error:\n" ++ showParseError e
|
||||
Right x -> unless (x == v) . expectationFailure $
|
||||
"expected: " ++ show v ++ "\nbut got: " ++ show x
|
||||
|
||||
-- | Create an expectation by saying that the parser should successfully
|
||||
-- parse a value and that the value should satisfy some predicate.
|
||||
--
|
||||
-- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length)
|
||||
|
||||
parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
|
||||
=> Either (ParseError t e) a
|
||||
-- ^ Result of parsing as returned by function like 'parse'
|
||||
-> (a -> Bool) -- ^ Predicate
|
||||
-> Expectation
|
||||
r `parseSatisfies` p = case r of
|
||||
Left e -> expectationFailure $
|
||||
"expected a parsed value to check against the predicate" ++
|
||||
"\nbut parsing failed with error:\n" ++ showParseError e
|
||||
Right x -> unless (p x) . expectationFailure $
|
||||
"the value did not satisfy the predicate: " ++ show x
|
||||
|
||||
-- | Check that a parser fails on some given input.
|
||||
--
|
||||
-- > parse (char 'x') "" `shouldFailOn` "a"
|
||||
|
||||
shouldFailOn :: Show a
|
||||
=> (s -> Either (ParseError t e) a)
|
||||
-- ^ Parser that takes stream and produces result or error message
|
||||
-> s -- ^ Input that the parser should fail on
|
||||
-> Expectation
|
||||
p `shouldFailOn` s = shouldFail (p s)
|
||||
|
||||
-- | Check that a parser succeeds on some given input.
|
||||
--
|
||||
-- > parse (char 'x') "" `shouldSucceedOn` "x"
|
||||
|
||||
shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
|
||||
=> (s -> Either (ParseError t e) a)
|
||||
-- ^ Parser that takes stream and produces result or error message
|
||||
-> s -- ^ Input that the parser should succeed on
|
||||
-> Expectation
|
||||
p `shouldSucceedOn` s = shouldSucceed (p s)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Testing of error messages
|
||||
|
||||
-- | Create an expectation that parser should fail producing certain
|
||||
-- 'ParseError'. Use functions from "Text.Megaparsec.Error" to construct
|
||||
-- parse errors to check against. See "Text.Megaparsec.Pos" for functions to
|
||||
-- construct textual positions.
|
||||
--
|
||||
-- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x')
|
||||
|
||||
shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
|
||||
=> Either (ParseError t e) a
|
||||
-> ParseError t e
|
||||
-> Expectation
|
||||
r `shouldFailWith` e = case r of
|
||||
Left e' -> unless (e == e') . expectationFailure $
|
||||
"the parser is expected to fail with:\n" ++ showParseError e ++
|
||||
"but it failed with:\n" ++ showParseError e'
|
||||
Right v -> expectationFailure $
|
||||
"the parser is expected to fail, but it parsed: " ++ show v
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Error message construction
|
||||
|
||||
-- $errmsg When you wish to test error message on failure, the need to
|
||||
-- construct a error message for comparison arises. These helpers allow to
|
||||
-- construct virtually any sort of error message easily.
|
||||
|
||||
-- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To
|
||||
-- create source position, two helpers are available: 'posI' and 'posN'.
|
||||
-- @'EC' t e@ is a monoid and can be built from primitives provided by this
|
||||
-- module, see below.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
err
|
||||
:: NonEmpty SourcePos -- ^ 'ParseError' position
|
||||
-> EC t e -- ^ Error components
|
||||
-> ParseError t e -- ^ Resulting 'ParseError'
|
||||
err pos (EC u e c) = ParseError pos u e c
|
||||
|
||||
-- | Initial source position with empty file name.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
posI :: NonEmpty SourcePos
|
||||
posI = initialPos "" :| []
|
||||
|
||||
-- | @posN n s@ returns source position achieved by applying 'updatePos'
|
||||
-- method corresponding to type of stream @s@ @n@ times.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
posN :: forall s n. (Stream s, Integral n)
|
||||
=> n
|
||||
-> s
|
||||
-> NonEmpty SourcePos
|
||||
posN n see = f (initialPos "") see n :| []
|
||||
where
|
||||
f p s !i =
|
||||
if i > 0
|
||||
then case uncons s of
|
||||
Nothing -> p
|
||||
Just (t,s') ->
|
||||
let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t
|
||||
in f p' s' (i - 1)
|
||||
else p
|
||||
|
||||
-- | Auxiliary type for construction of 'ParseError's. Note that it's a
|
||||
-- monoid.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
data EC t e = EC
|
||||
{ ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items
|
||||
, ecExpected :: Set (ErrorItem t) -- ^ Expected items
|
||||
, _ecCustom :: Set e -- ^ Custom items
|
||||
} deriving (Eq, Data, Typeable, Generic)
|
||||
|
||||
instance (Ord t, Ord e) => Semigroup (EC t e) where
|
||||
(EC u0 e0 c0) <> (EC u1 e1 c1) =
|
||||
EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1)
|
||||
|
||||
instance (Ord t, Ord e) => Monoid (EC t e) where
|
||||
mempty = EC E.empty E.empty E.empty
|
||||
mappend = (<>)
|
||||
|
||||
-- | Construct “unexpected token” error component.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
utok :: (Ord t, Ord e) => t -> EC t e
|
||||
utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t }
|
||||
|
||||
-- | Construct “unexpected tokens” error component. Empty string produces
|
||||
-- 'EndOfInput'.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
utoks :: (Ord t, Ord e) => [t] -> EC t e
|
||||
utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t }
|
||||
|
||||
-- | Construct “unexpected label” error component. Do not use with empty
|
||||
-- strings (for empty strings it's bottom).
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
ulabel :: (Ord t, Ord e) => String -> EC t e
|
||||
ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l }
|
||||
|
||||
-- | Construct “unexpected end of input” error component.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
ueof :: (Ord t, Ord e) => EC t e
|
||||
ueof = mempty { ecUnexpected = E.singleton EndOfInput }
|
||||
|
||||
-- | Construct “expected token” error component.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
etok :: (Ord t, Ord e) => t -> EC t e
|
||||
etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t }
|
||||
|
||||
-- | Construct “expected tokens” error component. Empty string produces
|
||||
-- 'EndOfInput'.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
etoks :: (Ord t, Ord e) => [t] -> EC t e
|
||||
etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t }
|
||||
|
||||
-- | Construct “expected label” error component. Do not use with empty
|
||||
-- strings.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
elabel :: (Ord t, Ord e) => String -> EC t e
|
||||
elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l }
|
||||
|
||||
-- | Construct “expected end of input” error component.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
eeof :: (Ord t, Ord e) => EC t e
|
||||
eeof = mempty { ecExpected = E.singleton EndOfInput }
|
||||
|
||||
-- | Construct custom error component.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
|
||||
cstm :: e -> EC t e
|
||||
cstm e = EC E.empty E.empty (E.singleton e)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Incremental parsing
|
||||
|
||||
-- | Check that a parser fails and leaves certain part of input
|
||||
-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
|
||||
-- that support incremental parsing.
|
||||
--
|
||||
-- > runParser' (many (char 'x') <* eof) (initialState "xxa")
|
||||
-- > `failsLeaving` "a"
|
||||
--
|
||||
-- See also: 'initialState'.
|
||||
|
||||
failsLeaving :: (Show a, Eq s, Show s, Stream s)
|
||||
=> (State s, Either (ParseError (Token s) e) a)
|
||||
-- ^ Parser that takes stream and produces result along with actual
|
||||
-- state information
|
||||
-> s -- ^ Part of input that should be left unconsumed
|
||||
-> Expectation
|
||||
(st,r) `failsLeaving` s =
|
||||
shouldFail r >> checkUnconsumed s (stateInput st)
|
||||
|
||||
-- | Check that a parser succeeds and leaves certain part of input
|
||||
-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
|
||||
-- that support incremental parsing.
|
||||
--
|
||||
-- > runParser' (many (char 'x')) (initialState "xxa")
|
||||
-- > `succeedsLeaving` "a"
|
||||
--
|
||||
-- See also: 'initialState'.
|
||||
|
||||
succeedsLeaving :: ( ShowToken (Token s)
|
||||
, ShowErrorComponent e
|
||||
, Show a
|
||||
, Eq s
|
||||
, Show s
|
||||
, Stream s )
|
||||
=> (State s, Either (ParseError (Token s) e) a)
|
||||
-- ^ Parser that takes stream and produces result along with actual
|
||||
-- state information
|
||||
-> s -- ^ Part of input that should be left unconsumed
|
||||
-> Expectation
|
||||
(st,r) `succeedsLeaving` s =
|
||||
shouldSucceed r >> checkUnconsumed s (stateInput st)
|
||||
|
||||
-- | Given input for parsing, construct initial state for parser (that is,
|
||||
-- with empty file name, default tab width and position at 1 line and 1
|
||||
-- column).
|
||||
|
||||
initialState :: s -> State s
|
||||
initialState s = State s (initialPos "" :| []) defaultTabWidth
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Helpers
|
||||
|
||||
-- | Expectation that argument is result of a failed parser.
|
||||
|
||||
shouldFail :: Show a => Either (ParseError t e) a -> Expectation
|
||||
shouldFail r = case r of
|
||||
Left _ -> return ()
|
||||
Right v -> expectationFailure $
|
||||
"the parser is expected to fail, but it parsed: " ++ show v
|
||||
|
||||
-- | Expectation that argument is result of a succeeded parser.
|
||||
|
||||
shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)
|
||||
=> Either (ParseError t e) a -> Expectation
|
||||
shouldSucceed r = case r of
|
||||
Left e -> expectationFailure $
|
||||
"the parser is expected to succeed, but it failed with:\n" ++
|
||||
showParseError e
|
||||
Right _ -> return ()
|
||||
|
||||
-- | Compare two streams for equality and in the case of mismatch report it.
|
||||
|
||||
checkUnconsumed :: (Eq s, Show s, Stream s)
|
||||
=> s -- ^ Expected unconsumed input
|
||||
-> s -- ^ Actual unconsumed input
|
||||
-> Expectation
|
||||
checkUnconsumed e a = unless (e == a) . expectationFailure $
|
||||
"the parser is expected to leave unconsumed input: " ++ show e ++
|
||||
"\nbut it left this: " ++ show a
|
||||
|
||||
-- | Render parse error in a way that is suitable for inserting it in test
|
||||
-- suite report.
|
||||
|
||||
showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)
|
||||
=> ParseError t e -> String
|
||||
showParseError = unlines . fmap (" " ++) . lines . parseErrorPretty
|
||||
|
||||
-- | Make a singleton non-empty list from a value.
|
||||
|
||||
nes :: a -> NonEmpty a
|
||||
nes x = x :| []
|
||||
{-# INLINE nes #-}
|
||||
|
||||
-- | Construct appropriate 'ErrorItem' representation for given token
|
||||
-- stream. Empty string produces 'EndOfInput'.
|
||||
|
||||
canonicalizeTokens :: [t] -> ErrorItem t
|
||||
canonicalizeTokens ts =
|
||||
case NE.nonEmpty ts of
|
||||
Nothing -> EndOfInput
|
||||
Just xs -> Tokens xs
|
185
tests/Test/Hspec/Megaparsec/AdHoc.hs
Normal file
185
tests/Test/Hspec/Megaparsec/AdHoc.hs
Normal file
@ -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))
|
450
tests/Text/Megaparsec/CharSpec.hs
Normal file
450
tests/Text/Megaparsec/CharSpec.hs
Normal file
@ -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
|
256
tests/Text/Megaparsec/CombinatorSpec.hs
Normal file
256
tests/Text/Megaparsec/CombinatorSpec.hs
Normal file
@ -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
|
214
tests/Text/Megaparsec/ErrorSpec.hs
Normal file
214
tests/Text/Megaparsec/ErrorSpec.hs
Normal file
@ -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
|
@ -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
|
480
tests/Text/Megaparsec/LexerSpec.hs
Normal file
480
tests/Text/Megaparsec/LexerSpec.hs
Normal file
@ -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)
|
125
tests/Text/Megaparsec/PermSpec.hs
Normal file
125
tests/Text/Megaparsec/PermSpec.hs
Normal file
@ -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' )
|
127
tests/Text/Megaparsec/PosSpec.hs
Normal file
127
tests/Text/Megaparsec/PosSpec.hs
Normal file
@ -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)
|
1088
tests/Text/Megaparsec/PrimSpec.hs
Normal file
1088
tests/Text/Megaparsec/PrimSpec.hs
Normal file
File diff suppressed because it is too large
Load Diff
369
tests/Util.hs
369
tests/Util.hs
@ -1,369 +0,0 @@
|
||||
--
|
||||
-- QuickCheck tests for Megaparsec, utility functions for parser testing.
|
||||
--
|
||||
-- Copyright © 2015–2016 Megaparsec contributors
|
||||
--
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
--
|
||||
-- * Redistributions of source code must retain the above copyright notice,
|
||||
-- this list of conditions and the following disclaimer.
|
||||
--
|
||||
-- * Redistributions in binary form must reproduce the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer in the
|
||||
-- documentation and/or other materials provided with the distribution.
|
||||
--
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
-- POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Util
|
||||
( checkParser
|
||||
, checkParser'
|
||||
, checkCase
|
||||
, checkCase'
|
||||
, simpleParse
|
||||
, checkChar
|
||||
, checkString
|
||||
, updatePosString
|
||||
, (/=\)
|
||||
, (!=!)
|
||||
, abcRow
|
||||
, EC (..)
|
||||
, posErr
|
||||
, posErr'
|
||||
, utok
|
||||
, utoks
|
||||
, ulabel
|
||||
, ueof
|
||||
, etok
|
||||
, etoks
|
||||
, elabel
|
||||
, eeof
|
||||
, cstm )
|
||||
where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Identity
|
||||
import Data.Foldable (foldl')
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe (mapMaybe, maybeToList)
|
||||
import qualified Control.Monad.State.Lazy as L
|
||||
import qualified Control.Monad.State.Strict as S
|
||||
import qualified Control.Monad.Writer.Lazy as L
|
||||
import qualified Control.Monad.Writer.Strict as S
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Set as E
|
||||
|
||||
import Test.QuickCheck
|
||||
import Test.HUnit (Assertion, (@?=))
|
||||
|
||||
import Text.Megaparsec.Error
|
||||
import Text.Megaparsec.Pos
|
||||
import Text.Megaparsec.Prim
|
||||
import Text.Megaparsec.String
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>), (<*>), (<*))
|
||||
#endif
|
||||
|
||||
-- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse
|
||||
-- entire @s@. Result of the parsing is compared with expected result @r@,
|
||||
-- it should match, otherwise the property doesn't hold and the test fails.
|
||||
|
||||
checkParser :: (Eq a, Show a)
|
||||
=> Parser a -- ^ Parser to test
|
||||
-> Either (ParseError Char Dec) a -- ^ Expected result of parsing
|
||||
-> String -- ^ Input for the parser
|
||||
-> Property -- ^ Resulting property
|
||||
checkParser p r s = simpleParse p s === r
|
||||
|
||||
-- | A variant of 'checkParser' that runs given parser code with all
|
||||
-- standard instances of 'MonadParsec'. Useful when testing primitive
|
||||
-- combinators.
|
||||
|
||||
checkParser' :: (Eq a, Show a)
|
||||
=> (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test
|
||||
-> Either (ParseError Char Dec) a -- ^ Expected result of parsing
|
||||
-> String -- ^ Input for the parser
|
||||
-> Property -- ^ Resulting property
|
||||
checkParser' p r s = conjoin
|
||||
[ checkParser p r s
|
||||
, checkParser (runIdentityT p) r s
|
||||
, checkParser (runReaderT p ()) r s
|
||||
, checkParser (L.evalStateT p ()) r s
|
||||
, checkParser (S.evalStateT p ()) r s
|
||||
, checkParser (evalWriterTL p) r s
|
||||
, checkParser (evalWriterTS p) r s ]
|
||||
|
||||
-- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.
|
||||
|
||||
checkCase :: (Eq a, Show a)
|
||||
=> Parser a -- ^ Parser to test
|
||||
-> Either (ParseError Char Dec) a -- ^ Expected result of parsing
|
||||
-> String -- ^ Input for the parser
|
||||
-> Assertion -- ^ Resulting assertion
|
||||
checkCase p r s = simpleParse p s @?= r
|
||||
|
||||
-- | Similar to 'checkParser'', but produces HUnit's 'Assertion's instead.
|
||||
|
||||
checkCase' :: (Eq a, Show a)
|
||||
=> (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test
|
||||
-> Either (ParseError Char Dec) a -- ^ Expected result of parsing
|
||||
-> String -- ^ Input for the parser
|
||||
-> Assertion -- ^ Resulting assertion
|
||||
checkCase' p r s = do
|
||||
parse p "" s @?= r
|
||||
parse (runIdentityT p) "" s @?= r
|
||||
parse (runReaderT p ()) "" s @?= r
|
||||
parse (L.evalStateT p ()) "" s @?= r
|
||||
parse (S.evalStateT p ()) "" s @?= r
|
||||
parse (evalWriterTL p) "" s @?= r
|
||||
parse (evalWriterTS p) "" s @?= r
|
||||
|
||||
evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
|
||||
evalWriterTL = liftM fst . L.runWriterT
|
||||
evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
|
||||
evalWriterTS = liftM fst . S.runWriterT
|
||||
|
||||
-- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding
|
||||
-- result of type @Either ParseError a@, where @a@ is type of parsed
|
||||
-- value. This parser tries to parser end of file too and name of input file
|
||||
-- is always empty string.
|
||||
|
||||
simpleParse :: Parser a -> String -> Either (ParseError Char Dec) a
|
||||
simpleParse p = parse (p <* eof) ""
|
||||
|
||||
-- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if
|
||||
-- the parser correctly parses single character that satisfies @test@. The
|
||||
-- character may be labelled, in this case @label@ is used to check quality
|
||||
-- of error messages.
|
||||
|
||||
checkChar
|
||||
:: Parser Char -- ^ Parser to run
|
||||
-> (Char -> Bool) -- ^ Predicate to test parsed char
|
||||
-> Maybe (ErrorItem Char) -- ^ Representation to use in error messages
|
||||
-> String -- ^ Input stream
|
||||
-> Property -- ^ Resulting property
|
||||
checkChar p f rep' s = checkParser p r s
|
||||
where h = head s
|
||||
rep = Expected <$> maybeToList rep'
|
||||
r | null s = posErr 0 s (ueof : rep)
|
||||
| length s == 1 && f h = Right h
|
||||
| not (f h) = posErr 0 s (utok h : rep)
|
||||
| otherwise = posErr 1 s [utok (s !! 1), eeof]
|
||||
|
||||
-- | @checkString p a test label s@ runs parser @p@ on input @s@ and checks if
|
||||
-- the result is equal to @a@ and also quality of error messages. @test@ is
|
||||
-- used to compare tokens. @label@ is used as expected representation of
|
||||
-- parser's result in error messages.
|
||||
|
||||
checkString
|
||||
:: Parser String -- ^ Parser to run
|
||||
-> String -- ^ Expected result
|
||||
-> (Char -> Char -> Bool) -- ^ Function used to compare tokens
|
||||
-> String -- ^ Input stream
|
||||
-> Property
|
||||
checkString p a' test s' = checkParser p (w a' 0 s') s'
|
||||
where w [] _ [] = Right s'
|
||||
w [] i (s:_) = posErr i s' [utok s, eeof]
|
||||
w _ 0 [] = posErr 0 s' [ueof, etoks a']
|
||||
w _ i [] = posErr 0 s' [utoks (take i s'), etoks a']
|
||||
w (a:as) i (s:ss)
|
||||
| test a s = w as i' ss
|
||||
| otherwise = posErr 0 s' [utoks (take i' s'), etoks a']
|
||||
where i' = succ i
|
||||
|
||||
-- | A helper function that is used to advance 'SourcePos' given a 'String'.
|
||||
|
||||
updatePosString
|
||||
:: Pos -- ^ Tab width
|
||||
-> SourcePos -- ^ Initial position
|
||||
-> String -- ^ 'String' — collection of tokens to process
|
||||
-> SourcePos -- ^ Final position
|
||||
updatePosString w = foldl' f
|
||||
where f p t = snd (defaultUpdatePos w p t)
|
||||
|
||||
infix 4 /=\ -- preserve whitespace on automatic trim
|
||||
|
||||
-- | @p /=\\ x@ runs parser @p@ on empty input and compares its result
|
||||
-- (which should be successful) with @x@. Succeeds when the result is equal
|
||||
-- to @x@, prints counterexample on failure.
|
||||
|
||||
(/=\) :: (Eq a, Show a) => Parser a -> a -> Property
|
||||
p /=\ x = simpleParse p "" === Right x
|
||||
|
||||
infix 4 !=!
|
||||
|
||||
-- | @n !=! m@ represents property that holds when results of running @n@
|
||||
-- and @m@ parsers are identical. This is useful when checking monad laws
|
||||
-- for example.
|
||||
|
||||
(!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property
|
||||
n !=! m = simpleParse n "" === simpleParse m ""
|
||||
|
||||
-- | @abcRow a b c@ generates string consisting of character “a” repeated
|
||||
-- @a@ times, character “b” repeated @b@ times, and finally character “c”
|
||||
-- repeated @c@ times.
|
||||
|
||||
abcRow :: Enum a => a -> a -> a -> String
|
||||
abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'
|
||||
where f x = replicate (fromEnum x)
|
||||
|
||||
-- | A component of parse error, useful for fast and dirty construction of
|
||||
-- parse errors with 'posErr' and other helpers.
|
||||
|
||||
data EC
|
||||
= Unexpected (ErrorItem Char)
|
||||
| Expected (ErrorItem Char)
|
||||
| Custom Dec
|
||||
|
||||
#if !MIN_VERSION_QuickCheck(2,9,0)
|
||||
instance Arbitrary a => Arbitrary (NonEmpty a) where
|
||||
arbitrary = NE.fromList . getNonEmpty <$> arbitrary
|
||||
#endif
|
||||
|
||||
instance Arbitrary t => Arbitrary (ErrorItem t) where
|
||||
arbitrary = oneof
|
||||
[ Tokens <$> arbitrary
|
||||
, Label <$> arbitrary
|
||||
, return EndOfInput ]
|
||||
|
||||
instance Arbitrary Pos where
|
||||
arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))
|
||||
|
||||
instance Arbitrary SourcePos where
|
||||
arbitrary = SourcePos
|
||||
<$> shortString
|
||||
<*> (unsafePos <$> choose (1, 1000))
|
||||
<*> (unsafePos <$> choose (1, 100))
|
||||
|
||||
instance Arbitrary Dec where
|
||||
arbitrary = oneof
|
||||
[ DecFail <$> shortString
|
||||
, DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]
|
||||
|
||||
instance (Arbitrary t, Ord t, Arbitrary e, Ord e)
|
||||
=> Arbitrary (ParseError t e) where
|
||||
arbitrary = ParseError
|
||||
<$> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
|
||||
shortString :: Gen String
|
||||
shortString = sized $ \n -> do
|
||||
k <- choose (0, n `div` 2)
|
||||
vectorOf k arbitrary
|
||||
|
||||
-- | @posErr pos s ms@ is an easy way to model result of parser that fails.
|
||||
-- @pos@ is how many tokens (characters) has been consumed before failure.
|
||||
-- @s@ is input of the parser. @ms@ is a list, collection of 'Message's. See
|
||||
-- 'utok', 'utoks', 'ulabel', 'ueof', 'etok', 'etoks', 'elabel', and 'eeof'
|
||||
-- for easy ways to create error messages.
|
||||
|
||||
posErr
|
||||
:: Int -- ^ How many tokens to drop from beginning of steam
|
||||
-> String -- ^ The input stream (just a 'String' here)
|
||||
-> [EC] -- ^ Collection of error components
|
||||
-> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'
|
||||
posErr i s = posErr' (pos :| [])
|
||||
where pos = updatePosString defaultTabWidth (initialPos "") (take i s)
|
||||
|
||||
-- | The same as 'posErr', but 'SourcePos' should be provided directly.
|
||||
|
||||
posErr'
|
||||
:: NonEmpty SourcePos -- ^ Position of the error
|
||||
-> [EC] -- ^ Collection of error components
|
||||
-> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'
|
||||
posErr' pos ecs = Left ParseError
|
||||
{ errorPos = pos
|
||||
, errorUnexpected = E.fromList (mapMaybe getUnexpected ecs)
|
||||
, errorExpected = E.fromList (mapMaybe getExpected ecs)
|
||||
, errorCustom = E.fromList (mapMaybe getCustom ecs) }
|
||||
where
|
||||
getUnexpected (Unexpected x) = Just x
|
||||
getUnexpected _ = Nothing
|
||||
getExpected (Expected x) = Just x
|
||||
getExpected _ = Nothing
|
||||
getCustom (Custom x) = Just x
|
||||
getCustom _ = Nothing
|
||||
|
||||
-- | Construct “unexpected token” error component.
|
||||
|
||||
utok :: Char -> EC
|
||||
utok = Unexpected . Tokens . nes
|
||||
|
||||
-- | Construct “unexpected steam” error component. This function respects
|
||||
-- some conventions described in 'canonicalizeStream'.
|
||||
|
||||
utoks :: String -> EC
|
||||
utoks = Unexpected . canonicalizeStream
|
||||
|
||||
-- | Construct “unexpected label” error component. Do not use with empty
|
||||
-- strings.
|
||||
|
||||
ulabel :: String -> EC
|
||||
ulabel = Unexpected . Label . NE.fromList
|
||||
|
||||
-- | Construct “unexpected end of input” error component.
|
||||
|
||||
ueof :: EC
|
||||
ueof = Unexpected EndOfInput
|
||||
|
||||
-- | Construct “expecting token” error component.
|
||||
|
||||
etok :: Char -> EC
|
||||
etok = Expected . Tokens . nes
|
||||
|
||||
-- | Construct “expecting stream” error component. This function respects
|
||||
-- some conventions described in 'canonicalizeStream'.
|
||||
|
||||
etoks :: String -> EC
|
||||
etoks = Expected . canonicalizeStream
|
||||
|
||||
-- | Construct “expecting label” error component. Do not use with empty
|
||||
-- strings.
|
||||
|
||||
elabel :: String -> EC
|
||||
elabel = Expected . Label . NE.fromList
|
||||
|
||||
-- | Construct “expecting end of input” component.
|
||||
|
||||
eeof :: EC
|
||||
eeof = Expected EndOfInput
|
||||
|
||||
-- | Construct error component consisting of custom data.
|
||||
|
||||
cstm :: Dec -> EC
|
||||
cstm = Custom
|
||||
|
||||
-- | Construct appropriate 'MessageItem' representation for given token
|
||||
-- stream. Empty string produces 'EndOfInput', single token — a 'Token', and
|
||||
-- in other cases the 'TokenStream' constructor is used.
|
||||
|
||||
canonicalizeStream :: String -> ErrorItem Char
|
||||
canonicalizeStream stream =
|
||||
case NE.nonEmpty stream of
|
||||
Nothing -> EndOfInput
|
||||
Just xs -> Tokens xs
|
||||
|
||||
-- | Make a singleton non-empty list from a value.
|
||||
|
||||
nes :: a -> NonEmpty a
|
||||
nes x = x :| []
|
||||
{-# INLINE nes #-}
|
Loading…
Reference in New Issue
Block a user