diff --git a/stack.yaml b/stack.yaml index d9cd3e6..ea77fba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,3 +3,4 @@ resolver: lts-15.8 extra-deps: - dependent-map-0.2.4.0 - dependent-sum-0.5 + - hspec-hedgehog-0.0.1.2 diff --git a/test/Test.hs b/test/Test.hs index 327adf4..657ce2c 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1 +1,21 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} +module Main + ( main + ) where + +import Test.Hspec (hspec) + +import Test.TypeRep.CMap (cMapSpec) +import Test.TypeRep.TypeRepMap (typeRepMapSpec) +import Test.TypeRep.TypeRepMapProperty (typeRepMapPropertySpec) +import Test.TypeRep.Vector (vectorSpec) +import Test.TypeRep.VectorOpt (optimalVectorSpec) + + +main :: IO () +main = hspec $ do + typeRepMapSpec + cMapSpec + vectorSpec + optimalVectorSpec + -- property + typeRepMapPropertySpec diff --git a/test/Test/TypeRep/CMap.hs b/test/Test/TypeRep/CMap.hs index fbb6eb1..24484e5 100644 --- a/test/Test/TypeRep/CMap.hs +++ b/test/Test/TypeRep/CMap.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.CMap where +module Test.TypeRep.CMap + ( cMapSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) +import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Tasty.Hspec +import Data.TypeRep.CMap (TypeRepMap, empty, insert, lookup, size) -import Data.TypeRep.CMap --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = do +-- | Simple test for 'lookup', 'insert' and 'size' functions. +cMapSpec :: Spec +cMapSpec = describe "Containers Map TypeRep" $ do describe "Lookup Test" $ do it "returns the inserted element" $ lookup (insert (Identity 'a') empty) `shouldBe` Just (Identity 'a') diff --git a/test/Test/TypeRep/CacheMap.hs b/test/Test/TypeRep/TypeRepMap.hs similarity index 90% rename from test/Test/TypeRep/CacheMap.hs rename to test/Test/TypeRep/TypeRepMap.hs index 826c752..0a2f080 100644 --- a/test/Test/TypeRep/CacheMap.hs +++ b/test/Test/TypeRep/TypeRepMap.hs @@ -1,17 +1,20 @@ -module Test.TypeRep.CacheMap where +module Test.TypeRep.TypeRepMap + ( typeRepMapSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) import GHC.Exts (fromList) -import Test.Tasty.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, describe, it, shouldBe) import Data.TMap (TMap, empty, insert, lookup, one, size, union) import Data.TypeRepMap.Internal (WrapTypeable (..)) + -- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = do +typeRepMapSpec :: Spec +typeRepMapSpec = describe "TypeRepMap" $ do describe "Lookup Test" $ do it "returns the inserted element" $ lookup (fromList [WrapTypeable $ Identity 'a']) `shouldBe` Just 'a' diff --git a/test/Test/TypeRep/MapProperty.hs b/test/Test/TypeRep/TypeRepMapProperty.hs similarity index 63% rename from test/Test/TypeRep/MapProperty.hs rename to test/Test/TypeRep/TypeRepMapProperty.hs index edb1d29..f136df9 100644 --- a/test/Test/TypeRep/MapProperty.hs +++ b/test/Test/TypeRep/TypeRepMapProperty.hs @@ -6,7 +6,9 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -module Test.TypeRep.MapProperty where +module Test.TypeRep.TypeRepMapProperty + ( typeRepMapPropertySpec + ) where import Prelude hiding (lookup) @@ -15,43 +17,50 @@ import Data.Semigroup (Semigroup (..)) import GHC.Exts (fromList) import GHC.Stack (HasCallStack) import GHC.TypeLits (Nat, SomeNat (..), someNatVal) -import Hedgehog (MonadGen, PropertyT, forAll, property, (===), assert) -import Test.Tasty (TestName, TestTree) -import Test.Tasty.Hedgehog (testProperty) +import Hedgehog (MonadGen, PropertyT, assert, forAll, property, (===)) +import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it) +import Test.Hspec.Hedgehog (hedgehog) -import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member, invariantCheck) +import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck, + lookup, member) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ----------------------------------------------------------------------------- --- Common utils ----------------------------------------------------------------------------- -type PropertyTest = [TestTree] - -prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest -prop testName = pure . testProperty testName . property +typeRepMapPropertySpec :: Spec +typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do + describe "Map modification properties" $ do + insertLookupSpec + insertInsertSpec + deleteMemberSpec + insertInvariantSpec + deleteInvariantSpec + describe "Instance Laws" $ do + semigroupAssocSpec + monoidIdentitySpec ---------------------------------------------------------------------------- -- Map modification properties ---------------------------------------------------------------------------- -test_InsertLookup :: PropertyTest -test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do +type Property = SpecWith (Arg Expectation) + +insertLookupSpec :: Property +insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do m <- forAll genMap WrapTypeable (proxy :: IntProxy n) <- forAll genTF lookup @n @IntProxy (insert proxy m) === Just proxy -test_InsertInsert :: PropertyTest -test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do +insertInsertSpec :: Property +insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do m <- forAll genMap WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF let b = IntProxy proxy (i + 1) lookup @n @IntProxy (insert b $ insert a m) === Just b -test_DeleteMember :: PropertyTest -test_DeleteMember = prop "member k . delete k == False" $ do +deleteMemberSpec :: Property +deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do m <- forAll genMap WrapTypeable (proxy :: IntProxy n) <- forAll genTF shouldInsert <- forAll Gen.bool @@ -61,14 +70,14 @@ test_DeleteMember = prop "member k . delete k == False" $ do else member @n (delete @n m) === False -test_InsertInvariant :: PropertyTest -test_InsertInvariant = prop "invariantCheck (insert k b) == True" $ do +insertInvariantSpec :: Property +insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do m <- forAll genMap WrapTypeable a <- forAll genTF assert $ invariantCheck (insert a m) -test_DeleteInvariant :: PropertyTest -test_DeleteInvariant = prop "invariantCheck (delete k b) == True" $ do +deleteInvariantSpec :: Property +deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do m <- forAll genMap WrapTypeable (_ :: IntProxy n) <- forAll genTF assert $ invariantCheck (delete @n m) @@ -78,20 +87,21 @@ test_DeleteInvariant = prop "invariantCheck (delete k b) == True" $ do ---------------------------------------------------------------------------- #if __GLASGOW_HASKELL__ < 806 --- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's --- not a good idea to write such `Eq` instance for `TypeRepMap` itself because --- it doesn't compare values so it's not true equality. But this should be --- enough for tests. +{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. +It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because +it doesn't compare values so it's not true equality. But this should be enough +for tests. +-} newtype FpMap f = FpMap (TypeRepMap f) - deriving newtype (Show, Semigroup, Monoid) + deriving newtype (Show, Semigroup, Monoid) instance Eq (FpMap f) where FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) = as1 == as2 && bs1 == bs2 #endif -test_SemigroupAssoc :: PropertyTest -test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do +semigroupAssocSpec :: Property +semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do #if __GLASGOW_HASKELL__ >= 806 x <- forAll genMap y <- forAll genMap @@ -101,11 +111,10 @@ test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do y <- FpMap <$> forAll genMap z <- FpMap <$> forAll genMap #endif - (x <> (y <> z)) === ((x <> y) <> z) -test_MonoidIdentity :: PropertyTest -test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do +monoidIdentitySpec :: Property +monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do #if __GLASGOW_HASKELL__ >= 806 x <- forAll genMap #else diff --git a/test/Test/TypeRep/Vector.hs b/test/Test/TypeRep/Vector.hs index 58d3957..342faa7 100644 --- a/test/Test/TypeRep/Vector.hs +++ b/test/Test/TypeRep/Vector.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.Vector where +module Test.TypeRep.Vector + ( vectorSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) +import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Tasty.Hspec +import Data.TypeRep.Vector (TF (..), fromList, lookup) -import Data.TypeRep.Vector --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = +-- | Simple test for 'lookup', 'insert' and 'size' functions. +vectorSpec :: Spec +vectorSpec = describe "Vector TypeRep" $ describe "Lookup Test" $ do it "returns the inserted element" $ lookup (fromList [TF (Identity 'a')]) `shouldBe` Just (Identity 'a') diff --git a/test/Test/TypeRep/VectorOpt.hs b/test/Test/TypeRep/VectorOpt.hs index 65a6fbd..8b8f017 100644 --- a/test/Test/TypeRep/VectorOpt.hs +++ b/test/Test/TypeRep/VectorOpt.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.VectorOpt where +module Test.TypeRep.VectorOpt + ( optimalVectorSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) - -import Test.Tasty.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) import Data.TypeRep.OptimalVector (TF (..), fromList, lookup) --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = + +-- | Simple test for 'lookup', 'insert' and 'size' functions. +optimalVectorSpec :: Spec +optimalVectorSpec = describe "Optimal Vector TypeRep" $ describe "Lookup Test" $ do it "returns the inserted element" $ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a') diff --git a/typerep-map.cabal b/typerep-map.cabal index 1ab0c45..6f297ee 100644 --- a/typerep-map.cabal +++ b/typerep-map.cabal @@ -81,20 +81,17 @@ test-suite typerep-map-test main-is: Test.hs other-modules: Test.TypeRep.CMap - , Test.TypeRep.CacheMap - , Test.TypeRep.MapProperty + , Test.TypeRep.TypeRepMap + , Test.TypeRep.TypeRepMapProperty , Test.TypeRep.Vector , Test.TypeRep.VectorOpt - build-tool-depends: tasty-discover:tasty-discover build-depends: ghc-typelits-knownnat >= 0.4.2 && < 0.8 , hedgehog ^>= 1.0 + , hspec ^>= 2.7.1 + , hspec-hedgehog ^>= 0.0.1 , typerep-map , typerep-extra-impls - , tasty >= 1.0.1.1 && < 1.3 - , tasty-discover >= 4.1.1 && < 4.3 - , tasty-hedgehog ^>= 1.0.0.0 - , tasty-hspec ^>= 1.1.5 ghc-options: -threaded -rtsopts -with-rtsopts=-N