parser-combinators-tests (empty) → 1.0.3
raw patch · 9 files changed
+874/−0 lines, 9 filesdep +QuickCheckdep +basedep +hspecsetup-changed
Dependencies added: QuickCheck, base, hspec, hspec-expectations, hspec-megaparsec, megaparsec, megaparsec-tests, parser-combinators
Files
- LICENSE.md +28/−0
- README.md +11/−0
- Setup.hs +6/−0
- parser-combinators-tests.cabal +47/−0
- tests/Control/Applicative/CombinatorsSpec.hs +279/−0
- tests/Control/Applicative/PermutationsSpec.hs +103/−0
- tests/Control/Monad/Combinators/ExprSpec.hs +160/−0
- tests/Control/Monad/CombinatorsSpec.hs +239/−0
- tests/Spec.hs +1/−0
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright © 2017–2019 Mark Karpov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++* Neither the name Mark Karpov nor the names of contributors may be used to+ endorse or promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# Parser combinators tests++Test suite for the `parser-combinators` package as a separate package. This+allows us to avoid a circular dependency with `megaparsec` (which depends on+`parser-combinators`).++## License++Copyright © 2017–2019 Mark Karpov++Distributed under BSD 3 clause license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ parser-combinators-tests.cabal view
@@ -0,0 +1,47 @@+name: parser-combinators-tests+version: 1.0.3+cabal-version: 1.18+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5+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++source-repository head+ type: git+ location: https://github.com/mrkkrp/parser-combinators.git++flag dev+ description: Turn on development settings.+ manual: True+ default: False++test-suite tests+ main-is: Spec.hs+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ build-depends: QuickCheck >= 2.7 && < 2.13+ , base >= 4.9 && < 5.0+ , hspec >= 2.0 && < 3.0+ , hspec-expectations >= 0.8 && < 0.9+ , hspec-megaparsec >= 2.0 && < 3.0+ , megaparsec >= 7.0 && < 8.0+ , megaparsec-tests >= 7.0 && < 8.0+ , parser-combinators == 1.0.2+ 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
+ tests/Control/Applicative/CombinatorsSpec.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module Control.Applicative.CombinatorsSpec (spec) where++import Control.Applicative.Combinators+import Data.Char (isLetter, isDigit)+import Data.List (intersperse)+import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char++#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++spec :: Spec+spec = do++ describe "between" $+ it "works" . property $ \pre c n' post -> do+ let p = between (string pre) (string post) (many (char c))+ n = getNonNegative n'+ b = length (takeWhile (== c) post)+ z = replicate n c+ s = pre ++ z ++ post+ if b > 0+ then prs_ p s `shouldFailWith` err (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" $+ it "works" . property $ \cs' s' -> do+ let cs = getNonEmpty cs'+ p = choice (char <$> cs)+ s = [s']+ if s' `elem` cs+ then prs_ p s `shouldParse` s'+ else prs_ p s `shouldFailWith` err 0 (utok s' <> mconcat (etok <$> cs))++ 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 "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")++ 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 (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']+ 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 "someTill" $ do+ it "works" . property $ \a' b' c' -> do+ let [a,b,c] = getNonNegative <$> [a',b',c']+ p = (,) <$> someTill letterChar (char 'c') <*> many letterChar+ s = abcRow a b c+ if | null s ->+ prs_ p s `shouldFailWith` err 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 "option" $+ it "works" . property $ \d a s -> do+ let p = option d (string a)+ p' = fromMaybe d <$> optional (string a)+ prs_ p s `shouldBe` prs_ p' s++ describe "sepBy" $ 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
+ tests/Control/Applicative/PermutationsSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies #-}++module Control.Applicative.PermutationsSpec (spec) where++import Control.Applicative.Permutations+import Control.Monad+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 "toPermutationWithDefault" $ do+ let testCases =+ [ ("abc", "abc", "")+ , ("cba", "abc", "")+ , ("bbc", "xbz", "bc")+ , ("aaa", "ayz", "aa")+ , ("", "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+ 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", ",")+ ]+ 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, 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]
+ tests/Control/Monad/Combinators/ExprSpec.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Control.Monad.Combinators.ExprSpec (spec) where++import Control.Monad.Combinators.Expr+import Data.Monoid ((<>))+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 =+ describe "makeExprParser" $ do+ context "when given valid rendered AST" $+ it "can parse it back" $+ property $ \node -> do+ let s = showNode 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")+ context "when term is missing" $+ it "signals correct parse error" $ do+ let p = expr <* eof+ prs p "-" `shouldFailWith` err 1 (ueof <> elabel "term")+ prs p "(" `shouldFailWith` err 1 (ueof <> etok '-' <> elabel "term")+ prs p "*" `shouldFailWith` err 0 (utok '*' <> etok '-' <> elabel "term")+ context "operator is missing" $+ it "signals correct parse error" $+ property $ \a b -> do+ let p = expr <* eof+ a' = inParens a+ 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 '^'+ ])++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+ deriving (Eq, Show)++instance Enum Node where+ 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+ 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 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+showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y+showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y+showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y++showGT :: Node -> Node -> String+showGT parent node = (if node > parent then showCmp else showNode) node++showGE :: Node -> Node -> String+showGE parent node = (if node >= parent then showCmp else showNode) node++showCmp :: Node -> String+showCmp node = (if fromEnum node == 0 then showNode else inParens) node++inParens :: Node -> String+inParens x = "(" ++ showNode x ++ ")"++instance Arbitrary Node where+ arbitrary = sized arbitraryN0++arbitraryN0 :: Int -> Gen Node+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)]++arbitraryN2 :: Int -> Gen Node+arbitraryN2 0 = Val . getNonNegative <$> arbitrary+arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf+ where+ leaf = arbitraryN0 (n `div` 2)++lexeme :: Parser a -> Parser a+lexeme p = p <* hidden space++symbol :: String -> Parser String+symbol = lexeme . string++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++integer :: Parser Integer+integer = lexeme (read <$> some digitChar <?> "integer")++-- Here we use a table of operators that makes use of all features of+-- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex+-- but valid expressions and render them to get their textual+-- representation.++expr :: Parser Node+expr = makeExprParser term table++term :: Parser Node+term = parens expr <|> (Val <$> integer) <?> "term"++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 "-")] ]
+ tests/Control/Monad/CombinatorsSpec.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module Control.Monad.CombinatorsSpec (spec) where++import Control.Monad.Combinators+import Data.List (intersperse)+import Data.Maybe (maybeToList, isNothing, fromJust)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char++#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++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 $ \a' b' c' -> do+ let [a,b,c] = getNonNegative <$> [a',b',c']+ p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar+ s = abcRow a b c+ if c == 0+ then prs_ p s `shouldFailWith` err (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 "someTill" $ do+ it "works" . property $ \a' b' c' -> do+ let [a,b,c] = getNonNegative <$> [a',b',c']+ p = (,) <$> someTill letterChar (char 'c') <*> many letterChar+ s = abcRow a b c+ if | null s ->+ prs_ p s `shouldFailWith` err 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 "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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}