@@ -20,7 +20,8 @@ import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)
2020import Test.Hspec.Hedgehog (hedgehog)
2121
2222import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,
23− lookup, member, generateOrderMapping, fromSortedList)
23+ lookup, member, generateOrderMapping, fromSortedList, alter,
24+ adjust)
2425
2526import qualified Hedgehog.Gen as Gen
2627import qualified Hedgehog.Range as Range
@@ -34,6 +35,10 @@ typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do
3435 deleteMemberSpec
3536 insertInvariantSpec
3637 deleteInvariantSpec
38+ alterInsertSpec
39+ alterDeleteSpec
40+ alterAdjustSpec
41+ alterModifySpec
3742 describe "Internal helpers" $ do
3843 generateOrderMappingInvariantSpec
3944 describe "Instance Laws" $ do
@@ -82,11 +87,42 @@ deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do
8287 WrapTypeable (_ :: IntProxy n) <- forAll genTF
8388 assert $ invariantCheck (delete @n m)
8489
90+alterInsertSpec :: Property
91+alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do
92+ m <- forAll genMap
93+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF
94+ insert proxy m === alter (const (Just proxy)) m
95+
96+alterDeleteSpec :: Property
97+alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do
98+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF
99+ m <- insert proxy <$> forAll genMap
100+ delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m
101+
102+alterAdjustSpec :: Property
103+alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do
104+ m <- forAll genMap
105+ WrapTypeable (_ :: IntProxy n) <- forAll genTF
106+ let f (IntProxy p n) = IntProxy p (n * 10)
107+ adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m
108+
109+alterModifySpec :: Property
110+alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do
111+ m <- forAll genMap
112+ WrapTypeable (_ :: IntProxy n) <- forAll genTF
113+ randInt <- forAll (Gen.int Range.constantBounded)
114+ -- Function with some interesting behaviour, which inserts, seletes and modifies
115+ let f Nothing = Just (IntProxy Proxy randInt)
116+ f (Just (IntProxy p n))
117+ | even n = Nothing
118+ | otherwise = Just $ IntProxy p (n * 10)
119+ lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m)
120+
85121----------------------------------------------------------------------------
86122-- Internal helpers
87123----------------------------------------------------------------------------
88124generateOrderMappingInvariantSpec :: Property
89−generateOrderMappingInvariantSpec =
125+generateOrderMappingInvariantSpec =
90126 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do
91127 n <- forAll $ Gen.int (Range.linear 0 100)
92128 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]
@@ -95,41 +131,16 @@ generateOrderMappingInvariantSpec =
95131-- Semigroup and Monoid laws
96132----------------------------------------------------------------------------
97133
98−#if __GLASGOW_HASKELL__ < 806
99−{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.
100−It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because
101−it doesn't compare values so it's not true equality. But this should be enough
102−for tests.
103−-}
104−newtype FpMap f = FpMap (TypeRepMap f)
105− deriving newtype (Show, Semigroup, Monoid)
106−
107−instance Eq (FpMap f) where
108− FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =
109− as1 == as2 && bs1 == bs2
110−#endif
111−
112134semigroupAssocSpec :: Property
113135semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do
114−#if __GLASGOW_HASKELL__ >= 806
115136 x <- forAll genMap
116137 y <- forAll genMap
117138 z <- forAll genMap
118−#else
119− x <- FpMap <$> forAll genMap
120− y <- FpMap <$> forAll genMap
121− z <- FpMap <$> forAll genMap
122−#endif
123139 (x <> (y <> z)) === ((x <> y) <> z)
124140
125141monoidIdentitySpec :: Property
126142monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do
127−#if __GLASGOW_HASKELL__ >= 806
128143 x <- forAll genMap
129−#else
130− x <- FpMap <$> forAll genMap
131−#endif
132−
133144 x <> mempty === x
134145 mempty <> x === x
135146
@@ -150,3 +161,17 @@ genTF = do
150161 case someNatVal randNat of
151162 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt
152163 Nothing -> error "Invalid test generator"
164+
165+----------------------------------------------------------------------------
166+-- Helpers
167+----------------------------------------------------------------------------
168+#if __GLASGOW_HASKELL__ < 806
169+{- | We add an orphan Eq instance for old GHC versions just to make testing easier.
170+It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because
171+it doesn't compare values so it's not true equality. But this should be enough
172+for tests.
173+-}
174+instance Eq (TypeRepMap f) where
175+ TypeRepMap as1 bs1 _ _ == TypeRepMap as2 bs2 _ _ =
176+ as1 == as2 && bs1 == bs2
177+#endif