megaparsec/tests/Text/Megaparsec/CombinatorSpec.hs

257 lines
9.7 KiB
Haskell
Raw Normal View History

2016-09-04 17:00:46 +03:00
--
-- Tests for Megaparsec's generic parser combinators.
--
-- Copyright © 20152016 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)
2016-09-24 20:12:41 +03:00
import Data.Monoid
2016-09-04 17:00:46 +03:00
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