@@ -6,7 +6,9 @@
66
77{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
88
9−module Test.TypeRep.MapProperty where
9+module Test.TypeRep.TypeRepMapProperty
10+ ( typeRepMapPropertySpec
11+ ) where
1012
1113import Prelude hiding (lookup)
1214
@@ -15,43 +17,50 @@ import Data.Semigroup (Semigroup (..))
1517import GHC.Exts (fromList)
1618import GHC.Stack (HasCallStack)
1719import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
18−import Hedgehog (MonadGen, PropertyT, forAll, property, (===), assert)
19−import Test.Tasty (TestName, TestTree)
20−import Test.Tasty.Hedgehog (testProperty)
20+import Hedgehog (MonadGen, PropertyT, assert, forAll, property, (===))
21+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)
22+import Test.Hspec.Hedgehog (hedgehog)
2123
22−import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member, invariantCheck)
24+import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,
25+ lookup, member)
2326
2427import qualified Hedgehog.Gen as Gen
2528import qualified Hedgehog.Range as Range
2629
27−----------------------------------------------------------------------------
28−-- Common utils
29−----------------------------------------------------------------------------
30−
31−type PropertyTest = [TestTree]
3230
33−prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
34−prop testName = pure . testProperty testName . property
31+typeRepMapPropertySpec :: Spec
32+typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do
33+ describe "Map modification properties" $ do
34+ insertLookupSpec
35+ insertInsertSpec
36+ deleteMemberSpec
37+ insertInvariantSpec
38+ deleteInvariantSpec
39+ describe "Instance Laws" $ do
40+ semigroupAssocSpec
41+ monoidIdentitySpec
3542
3643----------------------------------------------------------------------------
3744-- Map modification properties
3845----------------------------------------------------------------------------
3946
40−test_InsertLookup :: PropertyTest
41−test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do
47+type Property = SpecWith (Arg Expectation)
48+
49+insertLookupSpec :: Property
50+insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do
4251 m <- forAll genMap
4352 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
4453 lookup @n @IntProxy (insert proxy m) === Just proxy
4554
46−test_InsertInsert :: PropertyTest
47−test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do
55+insertInsertSpec :: Property
56+insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do
4857 m <- forAll genMap
4958 WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
5059 let b = IntProxy proxy (i + 1)
5160 lookup @n @IntProxy (insert b $ insert a m) === Just b
5261
53−test_DeleteMember :: PropertyTest
54−test_DeleteMember = prop "member k . delete k == False" $ do
62+deleteMemberSpec :: Property
63+deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do
5564 m <- forAll genMap
5665 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
5766 shouldInsert <- forAll Gen.bool
@@ -61,14 +70,14 @@ test_DeleteMember = prop "member k . delete k == False" $ do
6170 else
6271 member @n (delete @n m) === False
6372
64−test_InsertInvariant :: PropertyTest
65−test_InsertInvariant = prop "invariantCheck (insert k b) == True" $ do
73+insertInvariantSpec :: Property
74+insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do
6675 m <- forAll genMap
6776 WrapTypeable a <- forAll genTF
6877 assert $ invariantCheck (insert a m)
6978
70−test_DeleteInvariant :: PropertyTest
71−test_DeleteInvariant = prop "invariantCheck (delete k b) == True" $ do
79+deleteInvariantSpec :: Property
80+deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do
7281 m <- forAll genMap
7382 WrapTypeable (_ :: IntProxy n) <- forAll genTF
7483 assert $ invariantCheck (delete @n m)
@@ -78,20 +87,21 @@ test_DeleteInvariant = prop "invariantCheck (delete k b) == True" $ do
7887----------------------------------------------------------------------------
7988
8089#if __GLASGOW_HASKELL__ < 806
81−-- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's
82−-- not a good idea to write such `Eq` instance for `TypeRepMap` itself because
83−-- it doesn't compare values so it's not true equality. But this should be
84−-- enough for tests.
90+{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.
91+It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because
92+it doesn't compare values so it's not true equality. But this should be enough
93+for tests.
94+-}
8595newtype FpMap f = FpMap (TypeRepMap f)
86− deriving newtype (Show, Semigroup, Monoid)
96+ deriving newtype (Show, Semigroup, Monoid)
8797
8898instance Eq (FpMap f) where
8999 FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =
90100 as1 == as2 && bs1 == bs2
91101#endif
92102
93−test_SemigroupAssoc :: PropertyTest
94−test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do
103+semigroupAssocSpec :: Property
104+semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do
95105#if __GLASGOW_HASKELL__ >= 806
96106 x <- forAll genMap
97107 y <- forAll genMap
@@ -101,11 +111,10 @@ test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do
101111 y <- FpMap <$> forAll genMap
102112 z <- FpMap <$> forAll genMap
103113#endif
104−
105114 (x <> (y <> z)) === ((x <> y) <> z)
106115
107−test_MonoidIdentity :: PropertyTest
108−test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do
116+monoidIdentitySpec :: Property
117+monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do
109118#if __GLASGOW_HASKELL__ >= 806
110119 x <- forAll genMap
111120#else