@@ -0,0 +1,85 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExplicitNamespaces #-}
3+{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+{-# LANGUAGE ViewPatterns #-}
10+
11+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver -fno-warn-orphans #-}
12+
13+module DMap
14+ ( benchDMap
15+ , prepareBenchDMap
16+ ) where
17+
18+import Criterion.Main (Benchmark, bench, bgroup, nf)
19+
20+import Prelude hiding (lookup)
21+
22+import Control.DeepSeq (rnf)
23+import Control.Exception
24+import Data.Functor.Identity (Identity (..))
25+import Data.Maybe (fromJust)
26+import Data.Proxy (Proxy (..))
27+import Data.Type.Equality ((:~:) (..))
28+import GHC.TypeLits
29+import Type.Reflection (TypeRep, Typeable, typeRep)
30+import Type.Reflection.Unsafe (typeRepFingerprint)
31+import Unsafe.Coerce (unsafeCoerce)
32+
33+import Data.Dependent.Map (DMap, empty, insert, keys, lookup)
34+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
35+import Data.Some (Some (This))
36+
37+benchDMap :: Benchmark
38+benchDMap = bgroup "dependent map"
39+ [ bench "lookup" $ nf tenLookups bigMap
40+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
41+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
42+ ]
43+
44+tenLookups :: DMap TypeRep Identity
45+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
46+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80
47+ )
48+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
49+ where
50+ lp :: forall (a :: Nat) . Typeable a => Proxy a
51+ lp = runIdentity $ fromJust $ lookup (typeRep @(Proxy a)) tmap
52+
53+-- TypeRepMap of 10000 elements
54+bigMap :: DMap TypeRep Identity
55+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty
56+
57+buildBigMap :: forall a . (KnownNat a)
58+ => Int
59+ -> Proxy (a :: Nat)
60+ -> DMap TypeRep Identity
61+ -> DMap TypeRep Identity
62+buildBigMap 1 x = insert (typeRep @(Proxy a)) $ Identity x
63+buildBigMap n x = insert (typeRep @(Proxy a)) (Identity x)
64+ . buildBigMap (n - 1) (Proxy @(a + 1))
65+
66+rknf :: DMap TypeRep f -> ()
67+rknf = rnf . map (\(This t) -> typeRepFingerprint t) . keys
68+
69+prepareBenchDMap :: IO ()
70+prepareBenchDMap = evaluate (rknf bigMap)
71+
72+instance GEq TypeRep where
73+ geq :: TypeRep a -> TypeRep b -> Maybe (a :~: b)
74+ geq (typeRepFingerprint -> a) (typeRepFingerprint -> b) =
75+ if a == b
76+ then Just $ unsafeCoerce Refl
77+ else Nothing
78+
79+instance GCompare TypeRep where
80+ gcompare :: TypeRep a -> TypeRep b -> GOrdering a b
81+ gcompare (typeRepFingerprint -> a) (typeRepFingerprint -> b) =
82+ case compare a b of
83+ EQ -> unsafeCoerce GEQ
84+ LT -> GLT
85+ GT -> GGT