{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-}
module Main where
import System.Exit
import Test.QuickCheck
import Test.QuickCheck.All
import Text.Parsec
import Control.Applicative
import Data.List
import Text.Parsec.Permutation
requireParse :: String -> Parsec String () a -> a
requireParse str parser =
case parse (parser <* eof) str str of
Left err -> error $ "Unsuccessful parse: " ++ show err
Right value -> value
prop_purePerm :: Property
prop_purePerm = once $
(requireParse "" $ runPermParser $ pure "test") == "test"
prop_purePerm2 :: Property
prop_purePerm2 = once $
case parse (runPermParser $ pure (, "asdf") <*> pure "qwer") "" "" of
Left _ -> False
Right x -> x == ("qwer", "asdf")
prop_oncePerm :: Property
prop_oncePerm = once $
case parse (runPermParser $ oncePerm $ char 'A') "" "A" of
Left _ -> False
Right x -> x == 'A'
prop_oncePerm2 :: Property
prop_oncePerm2 = once $
(requireParse "asdf" $ runPermParser $
(,,,,) <$> pure 'x'
<*> oncePerm (char 's')
<*> oncePerm (char 'a')
<*> oncePerm (char 'f')
<*> oncePerm (char 'd')) == ('x','s','a','f','d')
prop_oncePerm3 :: Property
prop_oncePerm3 = once $
(requireParse "a" $ runPermParser $
(,) <$> pure 'x'
<*> oncePerm (char 'a')) == ('x','a')
prop_oncePerm4 :: Property
prop_oncePerm4 = once $
(requireParse "as" $ runPermParser $
(,,) <$> pure 'x'
<*> oncePerm (char 's')
<*> oncePerm (char 'a')) == ('x','s','a')
prop_oncePerm5 :: Property
prop_oncePerm5 = once $
(requireParse "asf" $ runPermParser $
(,,,) <$> pure 'x'
<*> oncePerm (char 's')
<*> oncePerm (char 'a')
<*> oncePerm (char 'f')) == ('x','s','a','f')
prop_oncePerm6 :: Property
prop_oncePerm6 = once $
(requireParse "ab" $ runPermParser $
oncePerm (char 'a' >> return ('a',)) <*>
oncePerm (char 'b')) == ('a','b')
prop_oncePerm7 :: Property
prop_oncePerm7 = once $
(requireParse "ba" $ runPermParser $
oncePerm (char 'a' >> return ('a',)) <*>
oncePerm (char 'b')) == ('a','b')
prop_oncePerm8 :: Property
prop_oncePerm8 = once $
(requireParse "ba" $ runPermParser $
oncePerm (char 'a' >> return ('a',)) <*>
(oncePerm (char 'b' >> return ('b',)) <*> pure 'c')) == ('a',('b','c'))
prop_oncePerm9 :: Property
prop_oncePerm9 = once $
(requireParse "bac" $ runPermParser $
oncePerm (char 'a' >> return ('a',)) <*>
(oncePerm (char 'b' >> return ('b',)) <*>
oncePerm (char 'c'))) == ('a',('b','c'))
prop_oncePerm10 :: Property
prop_oncePerm10 = once $
(requireParse "" $ runPermParser $
pure ('a',) <*>
(pure ('b',) <*> pure 'c')) == ('a',('b','c'))
prop_oncePermAll' :: Property
prop_oncePermAll' = once $ all helper ["", "a", "ab", "bb", "abc", "abcb",
"abcdefg", "abccefaoeifjalasdfie"] where
helper str =
(requireParse str $ runPermParser $
foldr (\c parser ->
oncePerm (char c >> return (c:)) <*> parser)
(pure "Q") str
) == str ++ "Q"
prop_oncePermAll :: String -> Property
prop_oncePermAll str = property $
(requireParse (nub $ sort str) $ runPermParser $
foldr (\c parser ->
oncePerm (char c >> return (c:)) <*> parser)
(pure "Q") (nub $ sort str)
) == (nub $ sort str) ++ "Q"
prop_oncePermAllReverse :: String -> Property
prop_oncePermAllReverse str = property $
(requireParse (reverse $ nub $ sort str) $ runPermParser $
foldr (\c parser ->
oncePerm (char c >> return (c:)) <*> parser)
(pure "Q") (nub $ sort str)
) == (nub $ sort str) ++ "Q"
prop_oncePermMixedOrder1 :: Property
prop_oncePermMixedOrder1 = once $ expectFailure $
(requireParse "abcc" $ runPermParser $
oncePerm (char 'c' >> return ('c',,)) <*>
(oncePerm (char 'b' >> return ('b',)) <*>
oncePerm (char 'c')) <*>
oncePerm (char 'a')) == ('c',('b','c'),'a')
prop_oncePermMixedOrder1' :: Property
prop_oncePermMixedOrder1' = once $ expectFailure $
(requireParse "abc" $ runPermParser $
oncePerm (char 'c' >> return ('c',,)) <*>
oncePerm (char 'b') <*>
oncePerm (char 'a')) == ('c','b','a')
prop_oncePermMixedOrder2 :: Property
prop_oncePermMixedOrder2 = once $ expectFailure $
(requireParse "abbc" $ runPermParser $
oncePerm (char 'c' >> return ('c',,)) <*>
(oncePerm (char 'b' >> return ('b',)) <*>
oncePerm (char 'c')) <*>
oncePerm (char 'a')) == ('c',('b','c'),'a')
prop_oncePermMixedOrder3 :: Property
prop_oncePermMixedOrder3 = once $
(requireParse "axcb" $ runPermParser $
oncePerm (char 'b' >> return ('b',,)) <*>
(oncePerm (char 'x' >> return ('x',)) <*>
oncePerm (char 'c')) <*>
oncePerm (char 'a')) == ('b',('x','c'),'a')
prop_manyPermMixedOrder1 :: Property
prop_manyPermMixedOrder1 = once $
(requireParse "abcc" $ runPermParser $
(,,) <$>
manyPerm (char 'c') <*>
((,) <$>
manyPerm (char 'b') <*>
manyPerm (char 'c')) <*>
manyPerm (char 'a')) == ("cc",("b",""),"a")
prop_manyPermMixedOrder1' :: Property
prop_manyPermMixedOrder1' = once $ expectFailure $
(requireParse "abcc" $ runPermParser $
(,,) <$>
manyPerm (char 'c') <*>
((,) <$>
manyPerm (char 'b') <*>
many1Perm (char 'c')) <*>
manyPerm (char 'a')) == ("cc",("b",""),"a")
prop_manyPermMixedOrder2 :: Property
prop_manyPermMixedOrder2 = once $
(requireParse "abbc" $ runPermParser $
(,,) <$>
manyPerm (char 'c') <*>
((,) <$>
manyPerm (char 'b') <*>
manyPerm (char 'c')) <*>
manyPerm (char 'a')) == ("c",("bb",""),"a")
prop_manyPermMixedOrder3 :: Property
prop_manyPermMixedOrder3 = once $
(requireParse "abcb" $ runPermParser $
(,,) <$>
manyPerm (char 'b') <*>
((,) <$>
manyPerm (char 'b') <*>
manyPerm (char 'c')) <*>
manyPerm (char 'a')) == ("bb",("","c"),"a")
prop_manyPermMixedOrder4 :: Property
prop_manyPermMixedOrder4 = once $ expectFailure $
(requireParse "abcbxb" $ runPermParser $
(,,) <$>
oncePerm (char 'x') <*>
((,) <$>
optionMaybePerm (char 'b') <*>
manyPerm (anyChar)) <*>
manyPerm (char 'a')) /= ('q',(Just 'q',"qqq"),"qq")
prop_manyPermMixedOrder4' :: Property
prop_manyPermMixedOrder4' = once $
(requireParse "abczxb" $ runPermParser $
(,,) <$>
oncePerm (char 'x') <*>
((,) <$>
optionMaybePerm (char 'z') <*>
manyPerm (anyChar)) <*>
manyPerm (char 'a')) == ('x',(Just 'z',"cbb"),"a")
prop_manyPermAnyChar :: Property
prop_manyPermAnyChar = once $
(requireParse "abcbdef" $ runPermParser $
(,,) <$>
manyPerm (char 'b') <*>
manyPerm (anyChar) <*>
manyPerm (anyChar)) == ("bb","acdef","")
prop_optionPermAll :: String -> String -> Property
prop_optionPermAll str' optionalStr = property $
whenFail (putStrLn $ "str: " ++ show str) $
whenFail (putStrLn $ "optional: " ++ show optionalStr) $
whenFail (putStrLn $ "remainder: " ++ show (str \\ optionalStr)) $
whenFail (putStrLn $ "values: " ++ show ((map snd $
tail $ scanl (\(str, _) c ->
if c `elem` str
then (str \\ [c], Just c)
else (str, Nothing)) (str, Just 'Q')
optionalStr) ++ [Just 'Q'])) $
whenFail (putStrLn $ "actual: " ++ show (requireParse str $ runPermParser $
(,) <$>
foldr (\c parser ->
(:) <$> optionMaybePerm (char c) <*> parser)
(pure $ [Just 'Q']) optionalStr <*>
manyPerm anyChar)) $
(requireParse str $ runPermParser $
(,) <$>
foldr (\c parser ->
(:) <$> optionMaybePerm (char c) <*> parser)
(pure $ [Just 'Q']) optionalStr <*>
manyPerm anyChar
) == ( (map snd $
tail $ scanl (\(str, _) c ->
if c `elem` str
then (str \\ [c], Just c)
else (str, Nothing)) (str, Just 'Q')
optionalStr) ++ [Just 'Q']
, str \\ optionalStr)
where str = nub $ sort str'
main :: IO ()
main = do
success <- $quickCheckAll
if success then exitSuccess else exitFailure