diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/parser-combinators-tests.cabal b/parser-combinators-tests.cabal new file mode 100644 --- /dev/null +++ b/parser-combinators-tests.cabal @@ -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 +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 + +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 diff --git a/tests/Control/Applicative/CombinatorsSpec.hs b/tests/Control/Applicative/CombinatorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Applicative/CombinatorsSpec.hs @@ -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 diff --git a/tests/Control/Applicative/PermutationsSpec.hs b/tests/Control/Applicative/PermutationsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Applicative/PermutationsSpec.hs @@ -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] diff --git a/tests/Control/Monad/Combinators/ExprSpec.hs b/tests/Control/Monad/Combinators/ExprSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Monad/Combinators/ExprSpec.hs @@ -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 "-")] ] diff --git a/tests/Control/Monad/CombinatorsSpec.hs b/tests/Control/Monad/CombinatorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Monad/CombinatorsSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}