From e64c000e57b20f4994322c0ea34fd903b11f62f4 Mon Sep 17 00:00:00 2001
From: Veronika Romashkina <vrom911@gmail.com>
Date: Sat, 7 Jul 2018 22:20:57 +0800
Subject: [PATCH] Add benchmarks with DMap (#14)

* Add benchmarks with DMap

* Fix CI for 8.0.2
---
 benchmark/CacheMap.hs |  3 +-
 benchmark/DMap.hs     | 85 +++++++++++++++++++++++++++++++++++++++++++
 benchmark/Main.hs     | 11 ++++++
 typerep-map.cabal     |  6 ++-
 4 files changed, 101 insertions(+), 4 deletions(-)
 create mode 100644 benchmark/DMap.hs

diff --git a/benchmark/CacheMap.hs b/benchmark/CacheMap.hs
index f1c4599..0a24d5b 100644
--- a/benchmark/CacheMap.hs
+++ b/benchmark/CacheMap.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE ExplicitNamespaces   #-}
 {-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE PolyKinds            #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -25,7 +24,7 @@ import Data.Proxy (Proxy (..))
 import Data.Typeable (Typeable)
 import GHC.TypeLits
 
-import Data.TypeRep.Map (TF (..), TypeRepMap (..), fromList, lookup)
+import Data.TypeRep.CacheMap (TF (..), TypeRepMap (..), fromList, lookup)
 
 benchCacheMap :: Benchmark
 benchCacheMap = bgroup "vector optimal cache"
diff --git a/benchmark/DMap.hs b/benchmark/DMap.hs
new file mode 100644
index 0000000..94c0eb5
--- /dev/null
+++ b/benchmark/DMap.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE ExplicitNamespaces   #-}
+{-# LANGUAGE InstanceSigs         #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns         #-}
+
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver -fno-warn-orphans #-}
+
+module DMap
+       ( benchDMap
+       , prepareBenchDMap
+       ) where
+
+import Criterion.Main (Benchmark, bench, bgroup, nf)
+
+import Prelude hiding (lookup)
+
+import Control.DeepSeq (rnf)
+import Control.Exception
+import Data.Functor.Identity (Identity (..))
+import Data.Maybe (fromJust)
+import Data.Proxy (Proxy (..))
+import Data.Type.Equality ((:~:) (..))
+import GHC.TypeLits
+import Type.Reflection (TypeRep, Typeable, typeRep)
+import Type.Reflection.Unsafe (typeRepFingerprint)
+import Unsafe.Coerce (unsafeCoerce)
+
+import Data.Dependent.Map (DMap, empty, insert, keys, lookup)
+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
+import Data.Some (Some (This))
+
+benchDMap :: Benchmark
+benchDMap = bgroup "dependent map"
+   [ bench "lookup"     $ nf tenLookups bigMap
+   -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
+   -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
+   ]
+
+tenLookups :: DMap TypeRep Identity
+           -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
+              , Proxy 50, Proxy 60, Proxy 70, Proxy 80
+              )
+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
+  where
+    lp :: forall (a :: Nat) . Typeable a => Proxy a
+    lp = runIdentity $ fromJust $ lookup (typeRep @(Proxy a)) tmap
+
+-- TypeRepMap of 10000 elements
+bigMap :: DMap TypeRep Identity
+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty
+
+buildBigMap :: forall a . (KnownNat a)
+            => Int
+            -> Proxy (a :: Nat)
+            -> DMap TypeRep Identity
+            -> DMap TypeRep Identity
+buildBigMap 1 x = insert (typeRep @(Proxy a)) $ Identity x
+buildBigMap n x = insert (typeRep @(Proxy a)) (Identity x)
+                . buildBigMap (n - 1) (Proxy @(a + 1))
+
+rknf :: DMap TypeRep f -> ()
+rknf = rnf . map (\(This t) -> typeRepFingerprint t) . keys
+
+prepareBenchDMap :: IO ()
+prepareBenchDMap = evaluate (rknf bigMap)
+
+instance GEq TypeRep where
+    geq :: TypeRep a -> TypeRep b -> Maybe (a :~: b)
+    geq (typeRepFingerprint -> a) (typeRepFingerprint -> b) =
+        if a == b
+            then Just $ unsafeCoerce Refl
+            else Nothing
+
+instance GCompare TypeRep where
+    gcompare :: TypeRep a -> TypeRep b -> GOrdering a b
+    gcompare (typeRepFingerprint -> a) (typeRepFingerprint -> b) =
+        case compare a b of
+            EQ -> unsafeCoerce GEQ
+            LT -> GLT
+            GT -> GGT
diff --git a/benchmark/Main.hs b/benchmark/Main.hs
index 3409416..e97d39a 100644
--- a/benchmark/Main.hs
+++ b/benchmark/Main.hs
@@ -1,9 +1,14 @@
+{-# LANGUAGE CPP #-}
+
 module Main where
 
 import Criterion.Main (defaultMain)
 
 import CacheMap (benchCacheMap, prepareBenchCacheMap)
 import CMap (benchMap, prepareBenchMap)
+#if ( __GLASGOW_HASKELL__ >= 802 )
+import DMap (benchDMap, prepareBenchDMap)
+#endif
 import OptimalVector (benchVectorOpt, prepareBenchVectorOpt)
 --import Vector (benchVector, prepareBenchVector)
 
@@ -13,9 +18,15 @@ main = do
   prepareBenchCacheMap
   --prepareBenchVector
   prepareBenchVectorOpt
+#if ( __GLASGOW_HASKELL__ >= 802 )
+  prepareBenchDMap
+#endif
   defaultMain
     [ benchMap
    -- , benchVector
     , benchCacheMap
     , benchVectorOpt
+#if ( __GLASGOW_HASKELL__ >= 802 )
+    , benchDMap
+#endif
     ]
diff --git a/typerep-map.cabal b/typerep-map.cabal
index 9a66fa1..c13d446 100644
--- a/typerep-map.cabal
+++ b/typerep-map.cabal
@@ -76,15 +76,17 @@ benchmark typerep-map-benchmark
                      , OptimalVector
   build-depends:       base
                      , criterion
-                     , typerep-map
                      , typerep-map-internal
                      , deepseq
+                     , dependent-map
+                     , dependent-sum
                      , ghc-typelits-knownnat
   default-extensions:  OverloadedStrings
                        RecordWildCards
                        ScopedTypeVariables
                        TypeApplications
-
+  if impl(ghc >= 8.2.2)
+    other-modules:     DMap
 
 source-repository head
   type:                git