git.iko.soy/typerep-map
on 92b6021 help sign in
typerep-map/test/Test/TypeRep/MapProperty.hs
110 lines 4.0 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.Exts (fromList)
15import GHC.Stack (HasCallStack)
16import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
17import Hedgehog (MonadGen, PropertyT, forAll, property, (===))
18import Test.Tasty (TestName, TestTree)
19import Test.Tasty.Hedgehog (testProperty)
21import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member)
23import qualified Hedgehog.Gen as Gen
24import qualified Hedgehog.Range as Range
26----------------------------------------------------------------------------
27-- Common utils
28----------------------------------------------------------------------------
30type PropertyTest = [TestTree]
32prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
33prop testName = pure . testProperty testName . property
35----------------------------------------------------------------------------
36-- Map modification properties
37----------------------------------------------------------------------------
39test_InsertLookup :: PropertyTest
40test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do
41 m <- forAll genMap
42 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
44 lookup @n @IntProxy (insert proxy m) === Just proxy
46test_InsertInsert :: PropertyTest
47test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do
48 m <- forAll genMap
49 WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
50 let b = IntProxy proxy (i + 1)
51 lookup @n @IntProxy (insert b $ insert a m) === Just b
53test_DeleteMember :: PropertyTest
54test_DeleteMember = prop "member k . delete k == False" $ do
55 m <- forAll genMap
56 WrapTypeable (proxy :: IntProxy n) <- forAll genTF
57 shouldInsert <- forAll Gen.bool
59 if shouldInsert then
60 member @n (delete @n $ insert proxy m) === False
61 else
62 member @n (delete @n m) === False
64----------------------------------------------------------------------------
65-- Semigroup and Monoid laws
66----------------------------------------------------------------------------
68-- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's
69-- not a good idea to write such `Eq` instance for `TypeRepMap` itself because
70-- it doesn't compare values so it's not true equality. But this should be
71-- enough for tests.
72newtype FpMap f = FpMap (TypeRepMap f)
73 deriving (Show, Semigroup, Monoid)
75instance Eq (FpMap f) where
76 FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =
77 as1 == as2 && bs1 == bs2
79test_SemigroupAssoc :: PropertyTest
80test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do
81 x <- FpMap <$> forAll genMap
82 y <- FpMap <$> forAll genMap
83 z <- FpMap <$> forAll genMap
85 (x <> (y <> z)) === ((x <> y) <> z)
87test_MonoidIdentity :: PropertyTest
88test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do
89 x <- FpMap <$> forAll genMap
91 x <> mempty === x
92 mempty <> x === x
94----------------------------------------------------------------------------
95-- Generators
96----------------------------------------------------------------------------
98data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
99 deriving (Show, Eq)
101genMap :: MonadGen m => m (TypeRepMap IntProxy)
102genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF
104genTF :: MonadGen m => m (WrapTypeable IntProxy)
105genTF = do
106 randNat :: Integer <- Gen.integral (Range.linear 0 10000)
107 randInt <- Gen.int Range.constantBounded
108 case someNatVal randNat of
109 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt
110 Nothing -> error "Invalid test generator"