parser-combinators-tests 1.2.1 → 1.3.0
raw patch · 6 files changed
+700/−401 lines, 6 filesdep ~QuickCheckdep ~basedep ~parser-combinators
Dependency ranges changed: QuickCheck, base, parser-combinators
Files
- parser-combinators-tests.cabal +48/−42
- tests/Control/Applicative/CombinatorsSpec.hs +172/−138
- tests/Control/Applicative/PermutationsSpec.hs +83/−32
- tests/Control/Monad/Combinators/ExprSpec.hs +87/−61
- tests/Control/Monad/CombinatorsSpec.hs +156/−128
- tests/Control/Monad/PermutationsSpec.hs +154/−0
parser-combinators-tests.cabal view
@@ -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 <markkarpov92@gmail.com>-maintainer: Mark Karpov <markkarpov92@gmail.com>-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 <markkarpov92@gmail.com>+author: Mark Karpov <markkarpov92@gmail.com>+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
tests/Control/Applicative/CombinatorsSpec.hs view
@@ -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
tests/Control/Applicative/PermutationsSpec.hs view
@@ -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]
tests/Control/Monad/Combinators/ExprSpec.hs view
@@ -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 "?")] ]
tests/Control/Monad/CombinatorsSpec.hs view
@@ -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
+ tests/Control/Monad/PermutationsSpec.hs view
@@ -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]