git.iko.soy/typerep-map
on 2df2fcd help sign in
typerep-map/test/Test/TypeRep/MapProperty.hs
109 lines 3.9 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE PolyKinds #-}
6{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
8module Test.TypeRep.MapProperty where
10import Prelude hiding (lookup)
12import Data.Proxy (Proxy (..))
13import Data.Semigroup (Semigroup (..))
14import GHC.Stack (HasCallStack)
15import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
16import Hedgehog (MonadGen, PropertyT, forAll, property, (===))
17import Test.Tasty (TestName, TestTree)
18import Test.Tasty.Hedgehog (testProperty)
20import Data.TypeRepMap.Internal (TF (..), TypeRepMap (..), delete, fromList, insert, lookup, member)
22import qualified Hedgehog.Gen as Gen
23import qualified Hedgehog.Range as Range
25----------------------------------------------------------------------------
26-- Common utils
27----------------------------------------------------------------------------
29type PropertyTest = [TestTree]
31prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
32prop testName = pure . testProperty testName . property
34----------------------------------------------------------------------------
35-- Map modification properties
36----------------------------------------------------------------------------
38test_InsertLookup :: PropertyTest
39test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do
40 m <- forAll genMap
41 TF (proxy :: IntProxy n) <- forAll genTF
43 lookup @n @IntProxy (insert proxy m) === Just proxy
45test_InsertInsert :: PropertyTest
46test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do
47 m <- forAll genMap
48 TF a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
49 let b = IntProxy proxy (i + 1)
50 lookup @n @IntProxy (insert b $ insert a m) === Just b
52test_DeleteMember :: PropertyTest
53test_DeleteMember = prop "member k . delete k == False" $ do
54 m <- forAll genMap
55 TF (proxy :: IntProxy n) <- forAll genTF
56 shouldInsert <- forAll Gen.bool
58 if shouldInsert then
59 member @n (delete @n $ insert proxy m) === False
60 else
61 member @n (delete @n m) === False
63----------------------------------------------------------------------------
64-- Semigroup and Monoid laws
65----------------------------------------------------------------------------
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.
71newtype FpMap f = FpMap (TypeRepMap f)
72 deriving (Show, Semigroup, Monoid)
74instance Eq (FpMap f) where
75 FpMap (TypeRepMap as1 bs1 _) == FpMap (TypeRepMap as2 bs2 _) =
76 as1 == as2 && bs1 == bs2
78test_SemigroupAssoc :: PropertyTest
79test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do
80 x <- FpMap <$> forAll genMap
81 y <- FpMap <$> forAll genMap
82 z <- FpMap <$> forAll genMap
84 (x <> (y <> z)) === ((x <> y) <> z)
86test_MonoidIdentity :: PropertyTest
87test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do
88 x <- FpMap <$> forAll genMap
90 x <> mempty === x
91 mempty <> x === x
93----------------------------------------------------------------------------
94-- Generators
95----------------------------------------------------------------------------
97data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
98 deriving (Show, Eq)
100genMap :: MonadGen m => m (TypeRepMap IntProxy)
101genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF
103genTF :: MonadGen m => m (TF IntProxy)
104genTF = do
105 randNat :: Integer <- Gen.integral (Range.linear 0 10000)
106 randInt <- Gen.int Range.constantBounded
107 case someNatVal randNat of
108 Just (SomeNat proxyNat) -> pure $ TF $ IntProxy proxyNat randInt
109 Nothing -> error "Invalid test generator"