git.iko.soy/typerep-map
on 73e7201 help sign in
typerep-map/test/Test/TypeRep/TypeRepMapProperty.hs
152 lines 5.4 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE PolyKinds #-}
6{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
8module Test.TypeRep.TypeRepMapProperty
9 ( typeRepMapPropertySpec
10 ) where
12import Prelude hiding (lookup)
14import Data.Proxy (Proxy (..))
15import Data.Semigroup (Semigroup (..))
16import GHC.Exts (fromList)
17import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
18import Hedgehog (MonadGen, assert, forAll, (===))
19import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)
20import Test.Hspec.Hedgehog (hedgehog)
22import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,
23 lookup, member, generateOrderMapping, fromSortedList)
25import qualified Hedgehog.Gen as Gen
26import qualified Hedgehog.Range as Range
29typeRepMapPropertySpec :: Spec
30typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do
31 describe "Map modification properties" $ do
32 insertLookupSpec
33 insertInsertSpec
34 deleteMemberSpec
35 insertInvariantSpec
36 deleteInvariantSpec
37 describe "Internal helpers" $ do
38 generateOrderMappingInvariantSpec
39 describe "Instance Laws" $ do
40 semigroupAssocSpec
41 monoidIdentitySpec
43----------------------------------------------------------------------------
44-- Map modification properties
45----------------------------------------------------------------------------
47type Property = SpecWith (Arg Expectation)
49insertLookupSpec :: Property
50insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do
51 m <- forAll genMap
52 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
53 lookup @n @IntProxy (insert proxy m) === Just proxy
55insertInsertSpec :: Property
56insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do
57 m <- forAll genMap
58 WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
59 let b = IntProxy proxy (i + 1)
60 lookup @n @IntProxy (insert b $ insert a m) === Just b
62deleteMemberSpec :: Property
63deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do
64 m <- forAll genMap
65 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
66 shouldInsert <- forAll Gen.bool
68 if shouldInsert then
69 member @n (delete @n $ insert proxy m) === False
70 else
71 member @n (delete @n m) === False
73insertInvariantSpec :: Property
74insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do
75 m <- forAll genMap
76 WrapTypeable a <- forAll genTF
77 assert $ invariantCheck (insert a m)
79deleteInvariantSpec :: Property
80deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do
81 m <- forAll genMap
82 WrapTypeable (_ :: IntProxy n) <- forAll genTF
83 assert $ invariantCheck (delete @n m)
85----------------------------------------------------------------------------
86-- Internal helpers
87----------------------------------------------------------------------------
88generateOrderMappingInvariantSpec :: Property
89generateOrderMappingInvariantSpec =
90 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do
91 n <- forAll $ Gen.int (Range.linear 0 100)
92 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]
94----------------------------------------------------------------------------
95-- Semigroup and Monoid laws
96----------------------------------------------------------------------------
98#if __GLASGOW_HASKELL__ < 806
99{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.
100It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because
101it doesn't compare values so it's not true equality. But this should be enough
102for tests.
103-}
104newtype FpMap f = FpMap (TypeRepMap f)
105 deriving newtype (Show, Semigroup, Monoid)
107instance Eq (FpMap f) where
108 FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =
109 as1 == as2 && bs1 == bs2
110#endif
112semigroupAssocSpec :: Property
113semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do
114#if __GLASGOW_HASKELL__ >= 806
115 x <- forAll genMap
116 y <- forAll genMap
117 z <- forAll genMap
118#else
119 x <- FpMap <$> forAll genMap
120 y <- FpMap <$> forAll genMap
121 z <- FpMap <$> forAll genMap
122#endif
123 (x <> (y <> z)) === ((x <> y) <> z)
125monoidIdentitySpec :: Property
126monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do
127#if __GLASGOW_HASKELL__ >= 806
128 x <- forAll genMap
129#else
130 x <- FpMap <$> forAll genMap
131#endif
133 x <> mempty === x
134 mempty <> x === x
136----------------------------------------------------------------------------
137-- Generators
138----------------------------------------------------------------------------
140data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
141 deriving stock (Show, Eq)
143genMap :: MonadGen m => m (TypeRepMap IntProxy)
144genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF
146genTF :: MonadGen m => m (WrapTypeable IntProxy)
147genTF = do
148 randNat :: Integer <- Gen.integral (Range.linear 0 10000)
149 randInt <- Gen.int Range.constantBounded
150 case someNatVal randNat of
151 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt
152 Nothing -> error "Invalid test generator"