diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Nicolas Del Piano + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +## Coverage + +### An exhaustivity checking library + +Copyright 2015, Nicolas Del Piano . + +This package provides a tool that performs exhaustivity and redundancy checking over custom pattern matching definitions. + +Installation: + + cabal install exhaustive + +You can see examples of usage in the `examples` directory and read the Haddock documentation. + +#### Tests + +For running tests (in the `tests` directory): + + runhaskell Spec.hs diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/coverage.cabal b/coverage.cabal new file mode 100644 --- /dev/null +++ b/coverage.cabal @@ -0,0 +1,50 @@ +name: coverage +version: 0.1.0.0 +synopsis: Exhaustivity Checking Library +homepage: https://github.com/nicodelpiano/coverage +bug-reports: https://github.com/nicodelpiano/coverage/issues +description: A library for exhaustivity and redundancy checking. +license: MIT +license-file: LICENSE +author: Nicolas Del Piano +maintainer: Nicolas Del Piano +copyright: (c) 2015 Nicolas Del Piano +category: Development +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +extra-source-files: + examples/*.hs + tests/*.hs + +source-repository head + type: git + location: https://github.com/nicodelpiano/coverage.git + +library + ghc-options: -Wall + exposed-modules: Coverage + Coverage.Internal + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + type: + exitcode-stdio-1.0 + ghc-options: + -Wall + hs-source-dirs: + tests, . + main-is: + Spec.hs + other-modules: + CoverageSpec + CoverageSupport + CoverageUnitSpec + build-depends: + base >=4.7 && <4.8, coverage, QuickCheck >=2.7, hspec == 2.* + default-language: Haskell2010 diff --git a/examples/Nat.hs b/examples/Nat.hs new file mode 100644 --- /dev/null +++ b/examples/Nat.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- +-- Module : Nat +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Example using nats. +-- +----------------------------------------------------------------------------- + +module Nat where + +import Coverage + +import Control.Arrow (first, second) + +-- | Nat +data Nat = Z | S Nat + deriving (Show, Eq) + +-- | Name binding association +data NatBinder = NullBinder -- Wildcard binder + | Zero -- Zero binder + | Succ NatBinder -- Succ binder + deriving (Show, Eq) + +natToBinder :: NatBinder -> Binder NatBinder +natToBinder NullBinder = Var Nothing +natToBinder Zero = Tagged "Zero" $ Var Nothing +natToBinder (Succ nb) = Tagged "Succ" $ natToBinder nb + +binderToNat :: Binder NatBinder -> NatBinder +binderToNat (Var Nothing) = NullBinder +binderToNat (Tagged "Zero" _) = Zero +binderToNat (Tagged "Succ" b) = Succ $ binderToNat b +binderToNat _ = error "The given binder is not valid." + +env :: String -> Maybe [String] +env "Zero" = Just $ + ["Zero", "Succ"] +env "Succ" = Just $ + ["Zero", "Succ"] +env _ = error "The given name is not a valid constructor." + +checkNat :: [([NatBinder], Maybe Guard)] -> ([[NatBinder]], [[NatBinder]]) +checkNat def = + let ch = check (makeEnv env) toBinder + in (map fromBinder $ getUncovered ch, map fromBinder $ fromRedundant $ getRedundant ch) + where + toBinder = map (\(nbs, g) -> (map natToBinder nbs, g)) def + + fromBinder = map binderToNat + + fromRedundant (NotRedundant bs) = bs + fromRedundant _ = [] diff --git a/examples/Tree.hs b/examples/Tree.hs new file mode 100644 --- /dev/null +++ b/examples/Tree.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- +-- Module : Tree +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Example using trees. +-- +----------------------------------------------------------------------------- + +module Tree where + +import Coverage + +import Control.Arrow (first, second) + +-- | Tree data-type +data Tree a = E + | L a + | B (Tree a) (Tree a) + deriving (Show, Eq) + +-- | Tree binders +data TreeBinder a = NullBinder + | Empty + | Leaf a + | Branch (TreeBinder a) (TreeBinder a) + deriving (Show, Eq) + +treeToBinder :: (Eq a) => TreeBinder a -> Binder a +treeToBinder NullBinder = Var Nothing +treeToBinder Empty = Tagged "Empty" $ Var Nothing +treeToBinder (Leaf l) = Tagged "Leaf" $ Lit l +treeToBinder (Branch l r) = Tagged "Branch" $ Product [treeToBinder l, treeToBinder r] + +binderToTree :: (Eq a) => Binder a -> TreeBinder (Maybe a) +binderToTree (Var Nothing) = NullBinder +binderToTree (Tagged "Empty" _) = Empty +binderToTree (Tagged "Leaf" (Lit l)) = Leaf $ Just l +binderToTree (Tagged "Leaf" (Var _)) = Leaf Nothing +binderToTree (Tagged "Branch" (Var _)) = Branch NullBinder NullBinder +binderToTree (Tagged "Branch" (Product [l, r])) = Branch (binderToTree l) (binderToTree r) +binderToTree _ = error "The given binder is not valid." + +env :: String -> Maybe [String] +env = go + where + maps = Just ["Empty", "Leaf", "Branch"] + + go "Empty" = maps + go "Leaf" = maps + go "Branch" = maps + go _ = error "The given name is not a valid constructor." + +checkTree :: (Eq a) => [([TreeBinder a], Maybe Guard)] -> ([[TreeBinder (Maybe a)]], [[TreeBinder (Maybe a)]]) +checkTree def = + let ch = check (makeEnv env) toBinder + in (map fromBinder $ getUncovered ch, map fromBinder $ fromRedundant $ getRedundant ch) + where + toBinder = map (\(nbs, g) -> (map treeToBinder nbs, g)) def + + fromBinder = map binderToTree + + fromRedundant (NotRedundant bs) = bs + fromRedundant _ = [] diff --git a/src/Coverage.hs b/src/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Coverage.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- +-- Module : Coverage +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Exhaustivity checking main function. +-- +----------------------------------------------------------------------------- + +module Coverage + ( check + , Binder(..) + , Guard(..) + , makeEnv + , Check(..) + , Redundant(..) + ) where + +import Coverage.Internal + +import Data.List (foldl', nub) +import Data.Maybe (fromMaybe) + +import Control.Applicative ((<$>), liftA2) + +-- | +-- Given a list of alternatives, `check` generates the proper set of uncovered cases. +-- +check :: (Eq lit) => Environment -> [Alternative lit] -> Check lit +check env cas = applyRedundant (fmap nub) . applyUncovered nub . foldl' step initial $ cas + where + initial = makeCheck [initialize $ length . fst . head $ cas] $ NotRedundant [] + + step :: (Eq lit) => Check lit -> Alternative lit -> Check lit + step ch ca = + let (missed, pr) = unzip $ map (missingAlternative env ca) $ getUncovered ch + cond = liftA2 (&&) (or <$> sequence pr) $ mr . getRedundant $ ch + in applyRedundant (\_ -> if fromMaybe True cond then getRedundant ch else fmap (fst ca :) $ getRedundant ch) + . applyUncovered (\unc -> if fromMaybe True cond then concat missed else unc) $ ch + where + mr :: Redundant [Binders lit] -> Maybe Bool + mr DontKnow = Nothing + mr Redundant = Just False + mr (NotRedundant _) = Just True diff --git a/src/Coverage/Internal.hs b/src/Coverage/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Coverage/Internal.hs @@ -0,0 +1,210 @@ +----------------------------------------------------------------------------- +-- +-- Module : Coverage.Internal +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Module for internal representation. +-- +----------------------------------------------------------------------------- + +module Coverage.Internal where + +import Data.List (sortBy) +import Data.Function (on) +import Data.Maybe (fromMaybe) + +import Control.Applicative (Applicative, (<*>), pure, liftA2) +import Control.Arrow (first) + +-- | A type synonym for names. +type Name = String + +-- | A collection of binders, as used to match products, in product binders +-- or collections of binders in top-level declarations. +type Binders lit = [Binder lit] + +-- | +-- Binders +-- +data Binder lit + = Var (Maybe Name) + | Lit lit + | Tagged Name (Binder lit) + | Product (Binders lit) + | Record [(Name, Binder lit)] + deriving (Show, Eq) + +-- | Environment +-- +-- The language implementor should provide an environment to let +-- the checker lookup for constructors' names (just for one type for now). +newtype Environment = Environment { envInfo :: Name -> Maybe [Name] } + +makeEnv :: (Name -> Maybe [Name]) -> Environment +makeEnv info = Environment { envInfo = info } + +defaultEnv :: Environment +defaultEnv = makeEnv (\_ -> Nothing) + +-- | Guards and alternatives +-- +-- Guard are abstract, and it is up to the language implementor to interpret +-- guards abstractly. Guards can catch all cases, or represent some opaque +-- expression which cannot be analysed. +data Guard = CatchAll | Opaque + deriving (Show, Eq) + +-- | A case alternative consists of a collection of binders which match +-- a collection of values, and an optional guard. +type Alternative lit = (Binders lit, Maybe Guard) + +-- | Data-type for redundant cases representation. +data Redundant a = DontKnow | Redundant | NotRedundant a + deriving (Show, Eq) + +-- | Functor instance for Redundant (TODO: proofs). +instance Functor Redundant where + fmap _ DontKnow = DontKnow + fmap _ Redundant = Redundant + fmap f (NotRedundant r) = NotRedundant $ f r + +-- | Applicative instance for Redundant. +instance Applicative Redundant where + pure = NotRedundant + + DontKnow <*> _ = DontKnow + Redundant <*> _ = Redundant + (NotRedundant f) <*> m = fmap f m + +-- | Check wraps both uncovered and redundant cases. +data Check lit = Check + { getUncovered :: [Binders lit] + , getRedundant :: Redundant [Binders lit] + } deriving (Show, Eq) + +makeCheck :: [Binders lit] -> Redundant [Binders lit] -> Check lit +makeCheck bs red = Check + { getUncovered = bs + , getRedundant = red } + +applyUncovered :: ([Binders lit] -> [Binders lit]) -> Check lit -> Check lit +applyUncovered f c = makeCheck (f $ getUncovered c) (getRedundant c) + +applyRedundant :: (Redundant [Binders lit] -> Redundant [Binders lit]) -> Check lit -> Check lit +applyRedundant f c = makeCheck (getUncovered c) (f $ getRedundant c) + +-- | Wildcard +wildcard :: Binder lit +wildcard = Var Nothing + +-- | +-- Applies a function over two lists of tuples that may lack elements. +-- +genericMerge :: Ord a => + (a -> Maybe b -> Maybe c -> d) -> + [(a, b)] -> + [(a, c)] -> + [d] +genericMerge _ [] [] = [] +genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs +genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs +genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') + | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr + | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs' + | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs' + +-- | Returns the uncovered set after one binder is applied to the set of +-- values represented by another. +missingSingle :: (Eq lit) => Environment -> Binder lit -> Binder lit -> ([Binder lit], Maybe Bool) +missingSingle _ _ (Var _) = ([], pure True) +missingSingle env (Var _) (Product ps) = + first (map Product) $ missingMultiple env (initialize $ length ps) ps +missingSingle env p@(Product ps) (Product ps') + | length ps == length ps' = first (map Product) $ missingMultiple env ps ps' + | otherwise = ([p], pure False) +missingSingle env (Var _) cb@(Tagged con _) = + (concatMap (\cp -> fst $ missingSingle env cp cb) $ tagEnv, pure True) + where + tag :: (Eq lit) => Name -> Binder lit + tag n = Tagged n wildcard + + tagEnv :: (Eq lit) => [Binder lit] + tagEnv = map tag + . fromMaybe (error $ "Constructor name '" ++ con ++ "' not in the scope of the current environment in missingSingle.") + . envInfo env $ con +missingSingle env c@(Tagged tag bs) (Tagged tag' bs') + | tag == tag' = let (bs'', pr) = missingSingle env bs bs' in (map (Tagged tag) bs'', pr) + | otherwise = ([c], pure False) +missingSingle env (Var _) (Record bs) = + (map (Record . zip names) $ miss, pr) + where + (miss, pr) = missingMultiple env (initialize $ length bs) binders + + (names, binders) = unzip bs +missingSingle env (Record bs) (Record bs') = + (map (Record . zip sortedNames) $ allMisses, pr) + where + (allMisses, pr) = uncurry (missingMultiple env) $ unzip binders + + sortNames = sortBy (compare `on` fst) + + (sbs, sbs') = (sortNames bs, sortNames bs') + + compB :: a -> Maybe a -> Maybe a -> (a, a) + compB e b b' = (fm b, fm b') + where + fm = fromMaybe e + + compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b)) + compBS e s b b' = (s, compB e b b') + + (sortedNames, binders) = unzip $ genericMerge (compBS (Var Nothing)) sbs sbs' +missingSingle _ b@(Lit l) (Lit l') + | l == l' = ([], pure True) + | otherwise = ([b], pure False) +missingSingle _ b _ = ([b], Nothing) + +-- | +-- Generates a list of initial binders. +-- +initialize :: Int -> [Binder lit] +initialize = flip replicate $ wildcard + +-- | +-- `missingMultiple` returns the whole set of uncovered cases. +-- +missingMultiple :: (Eq lit) => Environment -> Binders lit -> Binders lit -> ([Binders lit], Maybe Bool) +missingMultiple env = go + where + go [] [] = ([], pure True) + go (x:xs) (y:ys) = (map (: xs) missed ++ fmap (x :) missed', liftA2 (&&) pr1 pr2) + where + (missed, pr1) = missingSingle env x y + (missed', pr2) = go xs ys + go _ _ = error "Error in missingMultiple: invalid length of argument binders." + +-- | +-- `missingCases` applies `missingMultiple` to an alternative. +-- +missingCases :: (Eq lit) => Environment -> Binders lit -> Alternative lit -> ([Binders lit], Maybe Bool) +missingCases env unc = missingMultiple env unc . fst + +-- | +-- `missingAlternative` is `missingCases` with guard handling. +-- +missingAlternative :: (Eq lit) => Environment -> Alternative lit -> Binders lit -> ([Binders lit], Maybe Bool) +missingAlternative env alt unc + | isExhaustiveGuard $ snd alt = mcases + | otherwise = ([unc], snd mcases) + where + mcases = missingCases env unc alt + + isExhaustiveGuard :: Maybe Guard -> Bool + isExhaustiveGuard (Just Opaque) = False + isExhaustiveGuard _ = True diff --git a/tests/CoverageSpec.hs b/tests/CoverageSpec.hs new file mode 100644 --- /dev/null +++ b/tests/CoverageSpec.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- +-- Module : CoverageSpec +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Tests. +-- +----------------------------------------------------------------------------- + +module CoverageSpec (main, spec) where + +import Coverage +import Coverage.Internal +import CoverageSupport + +import Test.Hspec +import Test.HUnit +import Test.QuickCheck + +import Control.Exception (evaluate) + +spec :: Spec +spec = do + describe "Test suite" $ do + describe "missingSingle" $ do + it "between any binder and `Var _` should be `[]`" $ + property $ \b n -> fst (missingSingle defaultEnv (b :: Binder String) (Var n)) == [] + + it "between the same binders should be `[]`" $ + property $ \b -> fst (missingSingle defaultEnv (b :: Binder String) b) == [] + + it "if we covered something, then uncovered should be `[]`" $ + property $ \b b' -> + let (unc, cov) = missingSingle defaultEnv (b :: Binder String) (b' :: Binder String) + in cov == Just True ==> unc == [] + + it "if there are no uncovered cases, then we covered something" $ + property $ \b b' -> + let (unc, cov) = missingSingle defaultEnv (b :: Binder String) (b' :: Binder String) + in unc == [] ==> cov == Just True + +main :: IO () +main = hspec spec diff --git a/tests/CoverageSupport.hs b/tests/CoverageSupport.hs new file mode 100644 --- /dev/null +++ b/tests/CoverageSupport.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- +-- Module : CoverageSupport +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- QuickCheck instance for Binder data-type. +-- +----------------------------------------------------------------------------- + +module CoverageSupport where + +import Coverage.Internal + +import Control.Monad (liftM, liftM2, liftM3) + +import Test.QuickCheck + +-- | +-- Generates a list of binders. +-- +genBinders :: (Eq a, Arbitrary a) => Int -> Gen (Binders a) +genBinders 0 = return [] +genBinders n = liftM2 (:) arbitrary (genBinders (n-1)) + +-- | +-- Generates a list of pairs (name, binder). +-- +genRec :: (Eq a, Arbitrary a) => Int -> Gen [(Name, Binder a)] +genRec 0 = return [] +genRec n = liftM3 (\n b -> (:) (n, b)) arbitrary arbitrary (genRec (n-1)) + +-- | +-- Specific generators for each type of binder. +-- +genVar :: (Eq a, Arbitrary a) => Gen (Binder a) +genVar = liftM Var arbitrary + +-- | +-- Although necessary, there are no tests for tagged yet since +-- we need to construct an specific environment. +-- +genTagged :: (Eq a, Arbitrary a) => Gen (Binder a) +genTagged = liftM2 Tagged arbitrary arbitrary + +genLit :: (Eq a, Arbitrary a) => Gen (Binder a) +genLit = liftM Lit arbitrary + +genRecord :: (Eq a, Arbitrary a) => Gen (Binder a) +genRecord = liftM Record (choose (0, 2) >>= genRec) + +genProduct :: (Eq a, Arbitrary a) => Gen (Binder a) +genProduct = liftM Product (choose (0, 2) >>= genBinders) + +instance (Eq a, Arbitrary a) => Arbitrary (Binder a) where + arbitrary = oneof + [ genVar + , genLit + , genProduct + , genRecord + ] diff --git a/tests/CoverageUnitSpec.hs b/tests/CoverageUnitSpec.hs new file mode 100644 --- /dev/null +++ b/tests/CoverageUnitSpec.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- +-- Module : CoverageUnitSpec +-- Copyright : (c) 2015 Nicolas Del Piano +-- License : MIT +-- +-- Maintainer : Nicolas Del Piano +-- Stability : experimental +-- Portability : +-- +-- | +-- Unit tests. +-- +----------------------------------------------------------------------------- + +module CoverageUnitSpec (main, spec) where + +import Coverage +import Coverage.Internal +import CoverageSupport + +import Test.Hspec +import Test.HUnit +import Test.QuickCheck + +import Control.Exception (evaluate) + +env :: Environment +env = makeEnv env' + where + env' :: String -> Maybe [String] + env' "Zero" = Just $ + ["Zero", "Succ"] + env' "Succ" = Just $ + ["Zero", "Succ"] + env' _ = error "The given name is not a valid constructor." + +z :: Binder () +z = Tagged "Zero" wildcard + +s :: Binder () -> Binder () +s b = Tagged "Succ" b + +tagged_def1 :: [Alternative ()] +tagged_def1 = [([z], Nothing)] + +tagged_def2 :: [Alternative ()] +tagged_def2 = [([z], Nothing),([s wildcard], Nothing)] + +tagged_def3 :: [Alternative ()] +tagged_def3 = [([z, z], Nothing)] + +tagged_def4 :: [Alternative ()] +tagged_def4 = [([z, z], Nothing), ([wildcard, wildcard], Nothing)] + +tagged_def5 :: [Alternative ()] +tagged_def5 = [([wildcard], Nothing), ([z], Nothing)] + +tagged_def6 :: [Alternative ()] +tagged_def6 = [([wildcard, wildcard, wildcard], Nothing), ([z, z, z], Nothing)] + +fromRedundant (NotRedundant bs) = bs +fromRedundant _ = [] + +lit_def1 :: [Alternative String] +lit_def1 = [([Lit "hello"], Nothing)] + +record_def1 :: [Alternative ()] +record_def1 = [([Record [("foo", wildcard)]], Nothing)] + +record_def2 :: [Alternative ()] +record_def2 = [([Record [("foo", z)]], Nothing), ([Record [("bar", z), ("foo", s z)]], Nothing)] + +product_def1 :: [Alternative ()] +product_def1 = [([Product []], Nothing)] + +product_def2 :: [Alternative ()] +product_def2 = [([Product [z, z]], Nothing)] + +spec :: Spec +spec = do + describe "Unit tests" $ do + + describe "Literals" $ do + it "lit_def1 is not exhaustive" $ do + (getUncovered $ check defaultEnv lit_def1) `shouldBe` [[wildcard]] + + it "lit_def1 has redundant cases" $ do + (getUncovered $ check defaultEnv lit_def1) `shouldBe` [[wildcard]] + + describe "Tagged" $ do + it "tagged_def1 is not exhaustive" $ do + (getUncovered $ check env tagged_def1) `shouldBe` [[s wildcard]] + + it "tagged_def1 has not redundant cases" $ do + (fromRedundant $ getRedundant $ check env tagged_def1) `shouldBe` [] + + it "tagged_def2 is exhaustive" $ do + (getUncovered $ check env tagged_def2) `shouldBe` [] + + it "tagged_def3 is not exhaustive" $ do + (getUncovered $ check env tagged_def3) `shouldBe` [[s wildcard, wildcard], [wildcard, s wildcard]] + + it "tagged_def4 is exhaustive" $ do + (getUncovered $ check env tagged_def4) `shouldBe` [] + + it "tagged_def5 has redundant cases" $ do + (fromRedundant $ getRedundant $ check env tagged_def5) `shouldBe` [[z]] + + it "tagged_def6 has redundant cases" $ do + (fromRedundant $ getRedundant $ check env tagged_def6) `shouldBe` [[z, z, z]] + + describe "Record" $ do + it "record_def1 is exhaustive" $ do + (getUncovered $ check env record_def1) `shouldBe` [] + + it "record_def2 is not exhaustive" $ do + (getUncovered $ check env record_def2) `shouldBe` [[Record [("bar", s wildcard), ("foo", s wildcard)]], [Record [("bar", wildcard),("foo", s $ s wildcard)]]] + + describe "Product" $ do + it "product_def1 is exhaustive" $ do + (getUncovered $ check env record_def1) `shouldBe` [] + + it "product_def2 is not exhaustive" $ do + (getUncovered $ check env record_def1) `shouldBe` [] + +main :: IO () +main = hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +import Exhaustive.Internal