git.iko.soy/typerep-map
on main help sign in
Merge pull request #1 from vrom911/develop

Implement simple TypeRepMap

commitc8332ca4d7f7347c60239656d50456f679cb677e authorVeronika Romashkina <vrom911@gmail.com> dateSun 17 Dec 2017, 17:51 (9 years ago) parent4b3fd4e5de021d
7 files changed+164−65
compare with main
unifiedsplit
benchmark/Main.hs+59−2 src/Data/TypeRep/Map.hs+50 stack.yaml+3−58 test/Spec.hs−2 test/Test.hs+1 test/Test/TypeRep/Map.hs+41 typerep-map.cabal+10−3
benchmark/Main.hs+59−2
@@ -1,4 +1,61 @@
1−import Criterion.Main
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE ExplicitForAll #-}
4+{-# LANGUAGE ExplicitNamespaces #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
12+
13+import Criterion.Main (bench, defaultMain, nf, whnf)
14+
15+import Prelude hiding (lookup)
16+
17+import Control.DeepSeq (rnf)
18+import Control.Exception.Base (evaluate)
19+import Data.Maybe (fromJust)
20+import Data.Proxy (Proxy (..))
21+import Data.Typeable (Typeable)
22+import GHC.TypeLits
23+
24+import Data.TypeRep.Map (TypeRepMap (..), empty, insert, keys, lookup, size)
225
326main :: IO ()
4−main = defaultMain [bench "const" (whnf const ())]
27+main = do
28+ putStrLn $ "size: " ++ (show $ size bigMap)
29+ evaluate $ rknf bigMap
30+ defaultMain
31+ [ bench "lookup" $ nf tenLookups bigMap
32+ , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
33+ , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
34+ ]
35+
36+tenLookups :: TypeRepMap (Proxy :: Nat -> *)
37+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
38+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80
39+ )
40+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
41+ where
42+ lp :: forall (a::Nat). Typeable a => Proxy a
43+ lp = fromJust $ lookup tmap
44+
45+-- TypeRepMap of 10000 elements
46+bigMap :: TypeRepMap (Proxy :: Nat -> *)
47+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty
48+
49+data Z
50+data S a
51+
52+buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *)
53+buildBigMap 1 x = insert x
54+buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
55+
56+rknf :: TypeRepMap f -> ()
57+rknf = rnf . keys
58+
59+type family BigProxy (n :: Nat) :: * where
60+ BigProxy 0 = Z
61+ BigProxy n = S (BigProxy (n - 1))
src/Data/TypeRep/Map.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+
6+module Data.TypeRep.Map
7+ ( TypeRepMap (..)
8+ , empty
9+ , insert
10+ , keys
11+ , lookup
12+ , size
13+ ) where
14+
15+import Prelude hiding (lookup)
16+
17+import Data.Proxy (Proxy (..))
18+import Data.Typeable (TypeRep, Typeable, typeRep)
19+import GHC.Base (Any)
20+import Unsafe.Coerce (unsafeCoerce)
21+
22+import qualified Data.Map.Lazy as LMap
23+
24+-- | Map-like data structure with types served as the keys.
25+newtype TypeRepMap (f :: k -> *) = TypeRepMap
26+ { unMap :: LMap.Map TypeRep Any
27+ }
28+
29+-- | Empty structure.
30+empty :: TypeRepMap f
31+empty = TypeRepMap mempty
32+
33+-- | Inserts the value with its type as a key.
34+insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
35+insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap
36+
37+-- | Looks up the value at the type.
38+-- >>> let x = lookup $ insert (11 :: Int) empty
39+-- >>> x :: Maybe Int
40+-- Just 11
41+-- >>> x :: Maybe ()
42+-- Nothing
43+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
44+lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap
45+
46+size :: TypeRepMap f -> Int
47+size = LMap.size . unMap
48+
49+keys :: TypeRepMap f -> [TypeRep]
50+keys = LMap.keys . unMap
stack.yaml+3−58
@@ -1,66 +1,11 @@
1−# This file was automatically generated by 'stack init'
2−#
3−# Some commonly used options have been documented as comments in this file.
4−# For advanced use and comprehensive documentation of the format, please see:
5−# https://docs.haskellstack.org/en/stable/yaml_configuration/
6−
7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8−# A snapshot resolver dictates the compiler version and the set of packages
9−# to be used for project dependencies. For example:
10−#
11−# resolver: lts-3.5
12−# resolver: nightly-2015-09-21
13−# resolver: ghc-7.10.2
14−# resolver: ghcjs-0.1.0_ghc-7.10.2
15−# resolver:
16−# name: custom-snapshot
17−# location: "./custom-snapshot.yaml"
181resolver: lts-9.18
192
20−# User packages to be built.
21−# Various formats can be used as shown in the example below.
22−#
23−# packages:
24−# - some-directory
25−# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26−# - location:
27−# git: https://github.com/commercialhaskell/stack.git
28−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30−# extra-dep: true
31−# subdirs:
32−# - auto-update
33−# - wai
34−#
35−# A package marked 'extra-dep: true' will only be built if demanded by a
36−# non-dependency (i.e. a user package), and its test suites and benchmarks
37−# will not be run. This is useful for tweaking upstream packages.
383packages:
394- .
40−# Dependency packages to be pulled from upstream that are not in the resolver
41−# (e.g., acme-missiles-0.3)
42−extra-deps: []
435
44−# Override default flag values for local packages and extra-deps
6+extra-deps:
7+- tasty-discover-4.1.1
8+
459flags: {}
4610
47−# Extra package databases containing global packages
4811extra-package-dbs: []
49−
50−# Control whether we use the GHC we find on the path
51−# system-ghc: true
52−#
53−# Require a specific version of stack, using version ranges
54−# require-stack-version: -any # Default
55−# require-stack-version: ">=1.5"
56−#
57−# Override the architecture used by stack, especially useful on Windows
58−# arch: i386
59−# arch: x86_64
60−#
61−# Extra directories used by stack for building
62−# extra-include-dirs: [/path/to/dir]
63−# extra-lib-dirs: [/path/to/dir]
64−#
65−# Allow a newer minor version of GHC than the snapshot specifies
66−# compiler-check: newer-minor
test/Spec.hsdeleted−2
@@ -1,2 +0,0 @@
1−main :: IO ()
2−main = putStrLn "Test suite not yet implemented"
test/Test.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
test/Test/TypeRep/Map.hsnew file+41
@@ -0,0 +1,41 @@
1+module Test.TypeRep.Map where
2+
3+import Prelude hiding (lookup)
4+
5+import Data.Functor.Identity (Identity (..))
6+
7+import Test.Tasty.Hspec
8+
9+import Data.TypeRep.Map
10+
11+-- Simple test for 'lookup', 'insert' and 'size' functions.
12+spec_insertLookup :: Spec
13+spec_insertLookup = do
14+ describe "Lookup Test" $ do
15+ it "returns the inserted element" $
16+ lookup (insert (Identity 'a') empty) `shouldBe` Just (Identity 'a')
17+ it "returns the second inserted value of the same type" $
18+ lookup (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` Just (Identity 'b')
19+
20+ describe "Size Test" $ do
21+ it "is empty" $
22+ size empty `shouldBe` 0
23+ it "is of size 1 when 1 element inserted" $
24+ size (insert (Identity 'a') empty) `shouldBe` 1
25+ it "doesn't increase size when element of the same type is added" $
26+ size (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` 1
27+ it "returns 10 when 10 different types are inserted" $
28+ size mapOf10 `shouldBe` 10
29+
30+
31+mapOf10 :: TypeRepMap Identity
32+mapOf10 = insert (Identity True)
33+ $ insert (Identity [True, False])
34+ $ insert (Identity $ Just True)
35+ $ insert (Identity $ Just ())
36+ $ insert (Identity [()])
37+ $ insert (Identity ())
38+ $ insert (Identity "aaa")
39+ $ insert (Identity $ Just 'a')
40+ $ insert (Identity 'a')
41+ $ insert (Identity (11 :: Int)) empty
typerep-map.cabal+10−3
@@ -16,29 +16,36 @@ tested-with: GHC == 8.0.1
1616
1717library
1818 hs-source-dirs: src
19− exposed-modules: Lib
19+ exposed-modules: Data.TypeRep.Map
2020 ghc-options: -Wall
2121 build-depends: base
22+ , containers
2223 default-language: Haskell2010
2324
2425test-suite typerep-map-test
2526 type: exitcode-stdio-1.0
2627 hs-source-dirs: test
27− main-is: Spec.hs
28+ main-is: Test.hs
29+ other-modules: Test.TypeRep.Map
2830 build-depends: base
2931 , typerep-map
32+ , tasty
33+ , tasty-discover >= 4.1.1
34+ , tasty-hspec
3035 ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
3136 default-language: Haskell2010
3237
3338benchmark typerep-map-benchmark
3439 type: exitcode-stdio-1.0
3540 default-language: Haskell2010
36− ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
41+ ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0
3742 hs-source-dirs: benchmark
3843 main-is: Main.hs
3944 build-depends: base
4045 , criterion
4146 , typerep-map
47+ , deepseq
48+ , ghc-typelits-knownnat
4249
4350source-repository head
4451 type: git