{-# LANGUAGE MultiWayIf #-}
module Control.Monad.CombinatorsSpec (spec) where
import Control.Monad.Combinators
import Data.List (intersperse)
import Data.Maybe (fromJust, isNothing, maybeToList)
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc
import Test.QuickCheck
import Text.Megaparsec.Char
spec :: Spec
spec = do
describe "count" $ do
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
rightOrder (count 3 letterChar) "abc" "abc"
describe "count'" $ do
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 0 (utok 'x' <> eeof)
| m <= x && x <= n ->
prs_ p s `shouldParse` s
| x < m ->
prs_ p s `shouldFailWith` err x (ueof <> etok 'x')
| otherwise ->
prs_ p s `shouldFailWith` err n (utok 'x' <> eeof)
rightOrder (count' 1 3 letterChar) "abc" "abc"
describe "endBy" $ do
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 1 (ueof <> etok '-')
| c == 'a' ->
prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')
| c == '-' && n == 0 ->
prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a' <> eeof)
| c /= '-' ->
prs_ p s
`shouldFailWith` err
(g n)
( 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'
rightOrder (endBy letterChar (char ',')) "a,b,c," "abc"
describe "endBy1" $ do
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 (1 :: Int) (ueof <> etok '-')
| c == 'a' ->
prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')
| c == '-' && n == 0 ->
prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a')
| c /= '-' ->
prs_ p s
`shouldFailWith` err
(g n)
( 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'
rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc"
describe "manyTill" $ do
it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
let p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar
s = abcRow a b c
if c == 0
then
prs_ p s
`shouldFailWith` err
(a + b)
(ueof <> etok 'c' <> elabel "letter")
else
let (pre, post) = break (== 'c') s
in prs_ p s `shouldParse` (pre, drop 1 post)
rightOrder (manyTill letterChar (char 'd')) "abcd" "abc"
describe "manyTill_" $ do
it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
let p = (,) <$> manyTill_ letterChar (char 'c') <*> many letterChar
s = abcRow a b c
if c == 0
then
prs_ p s
`shouldFailWith` err
(a + b)
(ueof <> etok 'c' <> elabel "letter")
else
let (pre, post) = break (== 'c') s
in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post)
rightOrder (fmap fst . manyTill_ letterChar $ char 'd') "abcd" "abc"
describe "someTill" $ do
it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
let p = (,) <$> someTill letterChar (char 'c') <*> many letterChar
s = abcRow a b c
if
| null s ->
prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter")
| c == 0 ->
prs_ p s
`shouldFailWith` err
(a + b)
(ueof <> etok 'c' <> elabel "letter")
| s == "c" ->
prs_ p s `shouldFailWith` err 1 (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)
rightOrder (someTill letterChar (char 'd')) "abcd" "abc"
describe "someTill_" $ do
it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
let p = (,) <$> someTill_ letterChar (char 'c') <*> many letterChar
s = abcRow a b c
if
| null s ->
prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter")
| c == 0 ->
prs_ p s
`shouldFailWith` err
(a + b)
(ueof <> etok 'c' <> elabel "letter")
| s == "c" ->
prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter")
| head s == 'c' ->
prs_ p s `shouldParse` (("c", 'c'), drop 2 s)
| otherwise ->
let (pre, post) = break (== 'c') s
in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post)
rightOrder (fmap fst . someTill_ letterChar $ char 'd') "abcd" "abc"
describe "sepBy" $ do
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 0 (utok c <> etok 'a' <> eeof)
| c == '-' ->
prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')
| otherwise ->
prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)
rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"
describe "sepBy1" $ do
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 0 (ueof <> etok 'a')
| c == 'a' && n == 0 ->
prs_ p s `shouldParse` "a"
| n == 0 ->
prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')
| c == '-' ->
prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')
| otherwise ->
prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)
rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"
describe "sepEndBy" $ do
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 0 (utok c <> etok 'a' <> eeof)
| c == '-' ->
prs_ p s `shouldParse` a
| otherwise ->
prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)
rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"
describe "sepEndBy1" $ do
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 0 (ueof <> etok 'a')
| c == 'a' && n == 0 ->
prs_ p s `shouldParse` "a"
| n == 0 ->
prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')
| c == '-' ->
prs_ p s `shouldParse` a
| otherwise ->
prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)
rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"
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
describe "skipCount" $
it "works" . property $ \c n' a -> do
let p = skipCount n (char c) *> string a
n = getNonNegative n'
p' = count n (char c) *> string a
s = replicate n c ++ a
prs_ p s `shouldBe` prs_ p' s
describe "skipManyTill" $
it "works" . property $ \c n' a ->
c /= a ==> do
let p = skipManyTill (char c) (char a)
n = getNonNegative n'
s = replicate n c ++ [a]
prs_ p s `shouldParse` a
describe "skipSomeTill" $
it "works" . property $ \c n' a ->
c /= a ==> do
let p = skipSomeTill (char c) (char a)
n = getNonNegative n'
s = replicate n c ++ [a]
if n == 0
then prs_ p s `shouldFailWith` err 0 (utok a <> etok c)
else prs_ p s `shouldParse` a
----------------------------------------------------------------------------
-- Helpers
g :: Int -> Int
g x = x + if x > 0 then x - 1 else 0