@@ -1,6 +1,7 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE KindSignatures #-}
3−{-# LANGUAGE PolyKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
45
56{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
67
@@ -9,22 +10,31 @@ module Test.TypeRep.MapProperty where
910import Prelude hiding (lookup)
1011
1112import Data.Proxy (Proxy (..))
13+import Data.Semigroup (Semigroup (..))
1214import GHC.Stack (HasCallStack)
1315import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
1416import Hedgehog (MonadGen, PropertyT, forAll, property, (===))
1517import Test.Tasty (TestName, TestTree)
1618import Test.Tasty.Hedgehog (testProperty)
1719
18−import Data.TypeRep.Map (TF (..), TypeRepMap, delete, fromList, insert, lookup, member)
20+import Data.TypeRep.Map (TF (..), TypeRepMap (..), delete, fromList, insert, lookup, member)
1921
2022import qualified Hedgehog.Gen as Gen
2123import qualified Hedgehog.Range as Range
2224
25+----------------------------------------------------------------------------
26+-- Common utils
27+----------------------------------------------------------------------------
28+
2329type PropertyTest = [TestTree]
2430
2531prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
2632prop testName = pure . testProperty testName . property
2733
34+----------------------------------------------------------------------------
35+-- Map modification properties
36+----------------------------------------------------------------------------
37+
2838test_InsertLookup :: PropertyTest
2939test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do
3040 m <- forAll genMap
@@ -50,6 +60,36 @@ test_DeleteMember = prop "member k . delete k == False" $ do
5060 else
5161 member @n (delete @n m) === False
5262
63+----------------------------------------------------------------------------
64+-- Semigroup and Monoid laws
65+----------------------------------------------------------------------------
66+
67+-- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's
68+-- not a good idea to write such `Eq` instance for `TypeRepMap` itself because
69+-- it doesn't compare values so it's not true equality. But this should be
70+-- enough for tests.
71+newtype FpMap f = FpMap (TypeRepMap f)
72+ deriving (Show, Semigroup, Monoid)
73+
74+instance Eq (FpMap f) where
75+ FpMap (TypeRepMap as1 bs1 _) == FpMap (TypeRepMap as2 bs2 _) =
76+ as1 == as2 && bs1 == bs2
77+
78+test_SemigroupAssoc :: PropertyTest
79+test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do
80+ x <- FpMap <$> forAll genMap
81+ y <- FpMap <$> forAll genMap
82+ z <- FpMap <$> forAll genMap
83+
84+ (x <> (y <> z)) === ((x <> y) <> z)
85+
86+test_MonoidIdentity :: PropertyTest
87+test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do
88+ x <- FpMap <$> forAll genMap
89+
90+ x <> mempty === x
91+ mempty <> x === x
92+
5393----------------------------------------------------------------------------
5494-- Generators
5595----------------------------------------------------------------------------