diff --git a/parser-combinators-tests.cabal b/parser-combinators-tests.cabal --- a/parser-combinators-tests.cabal +++ b/parser-combinators-tests.cabal @@ -1,47 +1,53 @@ -name: parser-combinators-tests -version: 1.2.1 -cabal-version: 1.18 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 -license: BSD3 -license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/parser-combinators -bug-reports: https://github.com/mrkkrp/parser-combinators/issues -category: Parsing -synopsis: Test suite of parser-combinators -build-type: Simple -description: Test suite of parser-combinators. -extra-doc-files: README.md +cabal-version: 1.18 +name: parser-combinators-tests +version: 1.3.0 +license: BSD3 +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.3 +homepage: https://github.com/mrkkrp/parser-combinators +bug-reports: https://github.com/mrkkrp/parser-combinators/issues +synopsis: Test suite of parser-combinators +description: Test suite of parser-combinators. +category: Parsing +build-type: Simple +extra-doc-files: README.md source-repository head - type: git - location: https://github.com/mrkkrp/parser-combinators.git + type: git + location: https://github.com/mrkkrp/parser-combinators.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True -test-suite tests - main-is: Spec.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: QuickCheck >= 2.7 && < 2.14 - , base >= 4.11 && < 5.0 - , hspec >= 2.0 && < 3.0 - , hspec-expectations >= 0.8 && < 0.9 - , hspec-megaparsec >= 2.0 && < 3.0 - , megaparsec >= 8.0 && < 9.0 - , megaparsec-tests >= 8.0 && < 9.0 - , parser-combinators == 1.2.1 - other-modules: Control.Applicative.CombinatorsSpec - , Control.Applicative.PermutationsSpec - , Control.Monad.Combinators.ExprSpec - , Control.Monad.CombinatorsSpec - build-tools: hspec-discover >= 2.0 && < 3.0 - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 +test-suite test-suite + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tools: hspec-discover >=2.0 && <3.0 + hs-source-dirs: tests + other-modules: + Control.Applicative.CombinatorsSpec + Control.Applicative.PermutationsSpec + Control.Monad.Combinators.ExprSpec + Control.Monad.CombinatorsSpec + Control.Monad.PermutationsSpec + + default-language: Haskell2010 + build-depends: + QuickCheck >=2.7 && <2.15, + base >=4.12 && <5.0, + hspec >=2.0 && <3.0, + hspec-expectations >=0.8 && <0.9, + hspec-megaparsec >=2.0 && <3.0, + megaparsec >=8.0 && <10.0, + megaparsec-tests >=8.0 && <10.0, + parser-combinators ==1.3.0 + + if flag(dev) + ghc-options: -Wall -Werror + + else + ghc-options: -O2 -Wall diff --git a/tests/Control/Applicative/CombinatorsSpec.hs b/tests/Control/Applicative/CombinatorsSpec.hs --- a/tests/Control/Applicative/CombinatorsSpec.hs +++ b/tests/Control/Applicative/CombinatorsSpec.hs @@ -3,9 +3,9 @@ module Control.Applicative.CombinatorsSpec (spec) where import Control.Applicative.Combinators -import Data.Char (isLetter, isDigit) +import Data.Char (isDigit, isLetter) import Data.List (intersperse) -import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) +import Data.Maybe (fromJust, fromMaybe, isNothing, maybeToList) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -14,7 +14,6 @@ spec :: Spec spec = do - describe "between" $ it "works" . property $ \pre c n' post -> do let p = between (string pre) (string post) (many (char c)) @@ -23,11 +22,15 @@ z = replicate n c s = pre ++ z ++ post if b > 0 - then prs_ p s `shouldFailWith` err (length pre + n + b) - ( etoks post <> etok c <> - if length post == b - then ueof - else utoks (drop b post) ) + then + prs_ p s + `shouldFailWith` err + (length pre + n + b) + ( etoks post <> etok c + <> if length post == b + then ueof + else utoks (drop b post) + ) else prs_ p s `shouldParse` z describe "choice" $ @@ -53,44 +56,51 @@ 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) + 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 "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 0 (utok ch <> elabel "letter" <> elabel "digit") + if + | isLetter ch -> prs_ p s `shouldParse` Left ch + | isDigit ch -> prs_ p s `shouldParse` Right ch + | otherwise -> + prs_ p s + `shouldFailWith` err 0 (utok ch <> elabel "letter" <> elabel "digit") 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' + 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 @@ -98,80 +108,98 @@ 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 (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' + 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') + | 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 (a + b) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 (a + b) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) + 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 (fst <$> manyTill_ letterChar (char 'd')) "abcd" "abc" describe "someTill" $ do it "works" . property $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 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) + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 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) + 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 (fst <$> someTill_ letterChar (char 'd')) "abcd" "abc" describe "option" $ @@ -186,16 +214,17 @@ 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) + 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 @@ -204,18 +233,19 @@ 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) + 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 @@ -225,16 +255,17 @@ 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) + 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 @@ -244,18 +275,19 @@ 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) + 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" $ @@ -283,20 +315,22 @@ 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 + 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 + 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 diff --git a/tests/Control/Applicative/PermutationsSpec.hs b/tests/Control/Applicative/PermutationsSpec.hs --- a/tests/Control/Applicative/PermutationsSpec.hs +++ b/tests/Control/Applicative/PermutationsSpec.hs @@ -4,6 +4,7 @@ import Control.Applicative.Permutations import Control.Monad +import Data.List import Data.Void import Test.Hspec import Test.Hspec.Megaparsec @@ -18,36 +19,36 @@ describe "Functor instance" $ do it "obeys identity law" $ property $ \n -> - prsp (fmap id (pure (n :: Int))) "" === - prsp (id (pure n)) "" + prsp (fmap id (pure (n :: Int))) "" + === prsp (id (pure n)) "" it "obeys composition law" $ property $ \n m t -> let f = (+ m) g = (* t) - in prs (fmap (f . g) (pure (n :: Int))) "" === - prs ((fmap f . fmap g) (pure n)) "" + in prs (fmap (f . g) (pure (n :: Int))) "" + === prs ((fmap f . fmap g) (pure n)) "" describe "Applicative instance" $ do it "obeys identity law" $ property $ \n -> - prsp (pure id <*> pure (n :: Int)) "" === - prsp (pure n) "" + prsp (pure id <*> pure (n :: Int)) "" + === prsp (pure n) "" it "obeys composition law" $ property $ \n m t -> let u = pure (+ m) v = pure (* t) w = pure (n :: Int) - in prsp (pure (.) <*> u <*> v <*> w) "" === - prsp (u <*> (v <*> w)) "" + in prsp (pure (.) <*> u <*> v <*> w) "" + === prsp (u <*> (v <*> w)) "" it "obeys homomorphism law" $ property $ \x m -> let f = (+ m) - in prsp (pure f <*> pure (x :: Int)) "" === - prsp (pure (f x)) "" + in prsp (pure f <*> pure (x :: Int)) "" + === prsp (pure (f x)) "" it "obeys interchange law" $ property $ \n y -> let u = pure (+ n) - in prsp (u <*> pure (y :: Int)) "" === - prsp (pure ($ y) <*> u) "" + in prsp (u <*> pure (y :: Int)) "" + === prsp (pure ($ y) <*> u) "" describe "toPermutation" $ it "works" $ property $ \xs s' -> forAll (shuffle xs) $ \ys -> do @@ -56,42 +57,92 @@ f x p' = (:) <$> toPermutation (char x) <*> p' prsp p s `shouldParse` xs prsp' p s `succeedsLeaving` s' + describe "intercalateEffect" $ + it "works" $ + property $ \e xs s' -> + let preconditions f = + foldr1 + (.||.) + [ -- Zero permutation targets will cause problems + property $ null xs, + -- If the effect is the prefix of the suffix, it will fail + not (null s') .&&. e == head s', + f + ] + in preconditions $ + forAll (intersperse e <$> shuffle xs) $ \ys -> do + let s = ys ++ s' + p = intercalateEffect (char e) $ foldr f (pure []) xs + f x p' = (:) <$> toPermutation (char x) <*> p' + prs p s `shouldParse` xs + prs' p s `succeedsLeaving` s' describe "toPermutationWithDefault" $ do let testCases = - [ ("abc", "abc", "") - , ("cba", "abc", "") - , ("bbc", "xbz", "bc") - , ("aaa", "ayz", "aa") - , ("", "xyz", "") + [ ("abc", "abc", ""), + ("acb", "abc", ""), + ("bac", "abc", ""), + ("bca", "abc", ""), + ("cab", "abc", ""), + ("cba", "abc", ""), + ("aab", "ayz", "ab"), + ("aba", "abz", "a"), + ("baa", "abz", "a"), + ("bba", "xbz", "ba"), + ("bab", "abz", "b"), + ("abb", "abz", "b"), + ("cca", "xyc", "ca"), + ("cac", "ayc", "c"), + ("acc", "ayc", "c"), + ("aaa", "ayz", "aa"), + ("bbb", "xbz", "bb"), + ("ccc", "xyc", "cc"), + ("q", "xyz", "q"), + ("", "xyz", "") ] forM_ testCases $ \(i, o, r) -> it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do prsp testPermParser i `shouldParse` o prsp' testPermParser i `succeedsLeaving` r - describe "intercalateEffect" $ do + describe "intercalateEffect (with default)" $ do let p = intercalateEffect (char ',') testPermParser testCases = - [ ("a,b,c", "abc", "") - , ("c,b,a", "abc", "") - , ("b,b,c", "xbz", "b,c") - , ("a,a,a", "ayz", "a,a") - , (",", "xyz", ",") + [ ("a,b,c", "abc", ""), + ("a,c,b", "abc", ""), + ("b,a,c", "abc", ""), + ("b,c,a", "abc", ""), + ("c,a,b", "abc", ""), + ("c,b,a", "abc", ""), + ("aab", "ayz", "ab"), + ("a,ba", "abz", "a"), + ("b,aa", "abz", "a"), + ("bba", "xbz", "ba"), + ("b,ab", "abz", "b"), + ("a,bb", "abz", "b"), + ("cca", "xyc", "ca"), + ("c,ac", "ayc", "c"), + ("a,cc", "ayc", "c"), + ("aaa", "ayz", "aa"), + ("bbb", "xbz", "bb"), + ("ccc", "xyc", "cc"), + ("!", "xyz", "!"), + (",", "xyz", ","), + ("", "xyz", "") ] forM_ testCases $ \(i, o, r) -> it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do prs p i `shouldParse` o prs' p i `succeedsLeaving` r -prsp - :: Permutation Parser a - -> String - -> Either (ParseErrorBundle String Void) a +prsp :: + Permutation Parser a -> + String -> + Either (ParseErrorBundle String Void) a prsp p = prs (runPermutation p) -prsp' - :: Permutation Parser a - -> String - -> (State String Void, Either (ParseErrorBundle String Void) a) +prsp' :: + Permutation Parser a -> + String -> + (State String Void, Either (ParseErrorBundle String Void) a) prsp' p = prs' (runPermutation p) testPermParser :: Permutation Parser String @@ -100,4 +151,4 @@ <*> toPermutationWithDefault 'y' (char 'b') <*> toPermutationWithDefault 'z' (char 'c') where - f a b c = [a,b,c] + f a b c = [a, b, c] diff --git a/tests/Control/Monad/Combinators/ExprSpec.hs b/tests/Control/Monad/Combinators/ExprSpec.hs --- a/tests/Control/Monad/Combinators/ExprSpec.hs +++ b/tests/Control/Monad/Combinators/ExprSpec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Control.Monad.Combinators.ExprSpec (spec) where @@ -24,12 +24,14 @@ it "can parse it back" $ property $ \node -> do let s = showNode node - prs expr s `shouldParse` 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 0 - (ueof <> etok '-' <> elabel "term") + prs (expr <* eof) "" + `shouldFailWith` err + 0 + (ueof <> etok '-' <> elabel "term") context "when term is missing" $ it "signals correct parse error" $ do let p = expr <* eof @@ -41,58 +43,72 @@ property $ \a b -> do let p = expr <* eof a' = inParens a - n = length a' + 1 - s = a' ++ " " ++ inParens b - c = s !! n + 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 n (mconcat - [ utok c - , eeof - , etok '!' - , etok '%' - , etok '*' - , etok '+' - , etok '-' - , etok '/' - , etok '?' - , etok '^' - ]) + else + prs p s + `shouldFailWith` err + n + ( mconcat + [ utok c, + eeof, + etok '!', + etok '%', + etok '*', + etok '+', + etok '-', + etok '/', + etok '?', + etok '^' + ] + ) data Node - = Val Integer -- ^ literal value - | Neg Node -- ^ negation (prefix unary) - | Fac Node -- ^ factorial (postfix unary) - | Mod Node Node -- ^ modulo - | Sum Node Node -- ^ summation (addition) - | Sub Node Node -- ^ subtraction - | Pro Node Node -- ^ product - | Div Node Node -- ^ division - | Exp Node Node -- ^ exponentiation - | If Node Node Node -- ^ ternary conditional operator - deriving (Eq, Show) + = -- | literal value + Val Integer + | -- | negation (prefix unary) + Neg Node + | -- | factorial (postfix unary) + Fac Node + | -- | modulo + Mod Node Node + | -- | summation (addition) + Sum Node Node + | -- | subtraction + Sub Node Node + | -- | product + Pro Node Node + | -- | division + Div Node Node + | -- | exponentiation + Exp Node Node + | -- | ternary conditional operator + If Node Node Node + deriving (Eq, Show) instance Enum Node where - fromEnum (Val _) = 0 - fromEnum (Neg _) = 0 - fromEnum (Fac _) = 0 + fromEnum (Val _) = 0 + fromEnum (Neg _) = 0 + fromEnum (Fac _) = 0 fromEnum (Mod _ _) = 0 fromEnum (Exp _ _) = 1 fromEnum (Pro _ _) = 2 fromEnum (Div _ _) = 2 fromEnum (Sum _ _) = 3 fromEnum (Sub _ _) = 3 - fromEnum (If _ _ _ ) = 4 - toEnum _ = error "Oops!" + fromEnum (If _ _ _) = 4 + toEnum _ = error "Oops!" instance Ord Node where x `compare` y = fromEnum x `compare` fromEnum y showNode :: Node -> String -showNode (Val x) = show x -showNode n@(Neg x) = "-" ++ showGT n x -showNode n@(Fac x) = showGT n x ++ "!" +showNode (Val x) = show x +showNode n@(Neg x) = "-" ++ showGT n x +showNode n@(Fac x) = showGT n x ++ "!" showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y @@ -117,28 +133,35 @@ arbitrary = sized arbitraryN0 arbitraryN0 :: Int -> Gen Node -arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf) - , (9, arbitraryN1 n) ] +arbitraryN0 n = + frequency + [ (1, Mod <$> leaf <*> leaf), + (9, arbitraryN1 n) + ] where leaf = arbitraryN1 (n `div` 2) arbitraryN1 :: Int -> Gen Node arbitraryN1 n = - frequency [ (1, Neg <$> arbitraryN2 n) - , (1, Fac <$> arbitraryN2 n) - , (7, arbitraryN2 n)] + frequency + [ (1, Neg <$> arbitraryN2 n), + (1, Fac <$> arbitraryN2 n), + (7, arbitraryN2 n) + ] arbitraryN2 :: Int -> Gen Node arbitraryN2 0 = Val . getNonNegative <$> arbitrary arbitraryN2 n = (join . elements) - [ pure Sum - , pure Sub - , pure Pro - , pure Div - , pure Exp - , If <$> leaf - ] <*> leaf <*> leaf + [ pure Sum, + pure Sub, + pure Pro, + pure Div, + pure Exp, + If <$> leaf + ] + <*> leaf + <*> leaf where leaf = arbitraryN0 (n `div` 2) @@ -167,13 +190,16 @@ table :: [[Operator Parser Node]] table = - [ [ Prefix (Neg <$ symbol "-") - , Postfix (Fac <$ symbol "!") - , InfixN (Mod <$ symbol "%") ] - , [ InfixR (Exp <$ symbol "^") ] - , [ InfixL (Pro <$ symbol "*") - , InfixL (Div <$ symbol "/") ] - , [ InfixL (Sum <$ symbol "+") - , InfixL (Sub <$ symbol "-") ] - , [ TernR ((If <$ symbol ":") <$ symbol "?") ] + [ [ Prefix (Neg <$ symbol "-"), + Postfix (Fac <$ symbol "!"), + InfixN (Mod <$ symbol "%") + ], + [InfixR (Exp <$ symbol "^")], + [ InfixL (Pro <$ symbol "*"), + InfixL (Div <$ symbol "/") + ], + [ InfixL (Sum <$ symbol "+"), + InfixL (Sub <$ symbol "-") + ], + [TernR ((If <$ symbol ":") <$ symbol "?")] ] diff --git a/tests/Control/Monad/CombinatorsSpec.hs b/tests/Control/Monad/CombinatorsSpec.hs --- a/tests/Control/Monad/CombinatorsSpec.hs +++ b/tests/Control/Monad/CombinatorsSpec.hs @@ -4,7 +4,7 @@ import Control.Monad.Combinators import Data.List (intersperse) -import Data.Maybe (maybeToList, isNothing, fromJust) +import Data.Maybe (fromJust, isNothing, maybeToList) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -13,7 +13,6 @@ spec :: Spec spec = do - describe "count" $ do it "works" . property $ \n x' -> do let x = getNonNegative x' @@ -28,16 +27,17 @@ 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) + 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 @@ -45,18 +45,22 @@ 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' + 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 @@ -64,80 +68,98 @@ 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' + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 (a + b) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` (pre, drop 1 post) + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 (a + b) - (ueof <> etok 'c' <> elabel "letter") - else let (pre, post) = break (== 'c') s - in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 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) + 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 $ \a' b' c' -> do - let [a,b,c] = getNonNegative <$> [a',b',c'] + 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 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) + 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 @@ -146,16 +168,17 @@ 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) + 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 @@ -164,18 +187,19 @@ 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) + 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 @@ -185,16 +209,17 @@ 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) + 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 @@ -204,18 +229,19 @@ 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) + 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" $ @@ -243,20 +269,22 @@ 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 + 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 + 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 diff --git a/tests/Control/Monad/PermutationsSpec.hs b/tests/Control/Monad/PermutationsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Monad/PermutationsSpec.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE TypeFamilies #-} + +module Control.Monad.PermutationsSpec (spec) where + +import Control.Monad +import Control.Monad.Permutations +import Data.List +import Data.Void +import Test.Hspec +import Test.Hspec.Megaparsec +import Test.Hspec.Megaparsec.AdHoc +import Test.QuickCheck +import Text.Megaparsec +import Text.Megaparsec.Char + +spec :: Spec +spec = do + describe "runPermutation & Permutation" $ do + describe "Functor instance" $ do + it "obeys identity law" $ + property $ \n -> + prsp (fmap id (pure (n :: Int))) "" + === prsp (id (pure n)) "" + it "obeys composition law" $ + property $ \n m t -> + let f = (+ m) + g = (* t) + in prs (fmap (f . g) (pure (n :: Int))) "" + === prs ((fmap f . fmap g) (pure n)) "" + describe "Applicative instance" $ do + it "obeys identity law" $ + property $ \n -> + prsp (pure id <*> pure (n :: Int)) "" + === prsp (pure n) "" + it "obeys composition law" $ + property $ \n m t -> + let u = pure (+ m) + v = pure (* t) + w = pure (n :: Int) + in prsp (pure (.) <*> u <*> v <*> w) "" + === prsp (u <*> (v <*> w)) "" + it "obeys homomorphism law" $ + property $ \x m -> + let f = (+ m) + in prsp (pure f <*> pure (x :: Int)) "" + === prsp (pure (f x)) "" + it "obeys interchange law" $ + property $ \n y -> + let u = pure (+ n) + in prsp (u <*> pure (y :: Int)) "" + === prsp (pure ($ y) <*> u) "" + describe "toPermutation" $ + it "works" $ + property $ \xs s' -> forAll (shuffle xs) $ \ys -> do + let s = ys ++ s' + p = foldr f (pure []) xs + f x p' = (:) <$> toPermutation (char x) <*> p' + prsp p s `shouldParse` xs + prsp' p s `succeedsLeaving` s' + describe "intercalateEffect" $ + it "works" $ + property $ \e xs s' -> + let preconditions f = + foldr1 + (.||.) + [ -- Zero permutation targets will cause problems + property $ null xs, + -- If the effect is the prefix of the suffix, it will fail + not (null s') .&&. e == head s', + f + ] + in preconditions $ + forAll (intersperse e <$> shuffle xs) $ \ys -> do + let s = ys ++ s' + p = intercalateEffect (char e) $ foldr f (pure []) xs + f x p' = (:) <$> toPermutation (char x) <*> p' + prs p s `shouldParse` xs + prs' p s `succeedsLeaving` s' + describe "toPermutationWithDefault" $ do + let testCases = + [ ("abc", "abc", ""), + ("acb", "abc", ""), + ("bac", "abc", ""), + ("bca", "abc", ""), + ("cab", "abc", ""), + ("cba", "abc", ""), + ("aab", "ayz", "ab"), + ("aba", "abz", "a"), + ("baa", "abz", "a"), + ("bba", "xbz", "ba"), + ("bab", "abz", "b"), + ("abb", "abz", "b"), + ("cca", "xyc", "ca"), + ("cac", "ayc", "c"), + ("acc", "ayc", "c"), + ("aaa", "ayz", "aa"), + ("bbb", "xbz", "bb"), + ("ccc", "xyc", "cc"), + ("q", "xyz", "q"), + ("", "xyz", "") + ] + forM_ testCases $ \(i, o, r) -> + it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do + prsp testPermParser i `shouldParse` o + prsp' testPermParser i `succeedsLeaving` r + describe "intercalateEffect (with default)" $ do + let p = intercalateEffect (char ',') testPermParser + testCases = + [ ("a,b,c", "abc", ""), + ("a,c,b", "abc", ""), + ("b,a,c", "abc", ""), + ("b,c,a", "abc", ""), + ("c,a,b", "abc", ""), + ("c,b,a", "abc", ""), + ("aab", "ayz", "ab"), + ("a,ba", "abz", "a"), + ("b,aa", "abz", "a"), + ("bba", "xbz", "ba"), + ("b,ab", "abz", "b"), + ("a,bb", "abz", "b"), + ("cca", "xyc", "ca"), + ("c,ac", "ayc", "c"), + ("a,cc", "ayc", "c"), + ("aaa", "ayz", "aa"), + ("bbb", "xbz", "bb"), + ("ccc", "xyc", "cc"), + ("!", "xyz", "!"), + (",", "xyz", ","), + ("", "xyz", "") + ] + forM_ testCases $ \(i, o, r) -> + it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do + prs p i `shouldParse` o + prs' p i `succeedsLeaving` r + +prsp :: + Permutation Parser a -> + String -> + Either (ParseErrorBundle String Void) a +prsp p = prs (runPermutation p) + +prsp' :: + Permutation Parser a -> + String -> + (State String Void, Either (ParseErrorBundle String Void) a) +prsp' p = prs' (runPermutation p) + +testPermParser :: Permutation Parser String +testPermParser = + f <$> toPermutationWithDefault 'x' (char 'a') + <*> toPermutationWithDefault 'y' (char 'b') + <*> toPermutationWithDefault 'z' (char 'c') + where + f a b c = [a, b, c]