mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-12-18 13:51:58 +03:00
234 lines
9.5 KiB
Haskell
234 lines
9.5 KiB
Haskell
--
|
||
-- 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
|