git.iko.soy/typerep-map
on c3b71ea help sign in
88b9ac5
swap
10 ahead, 70 behind
benchmark/Main.hs+13−56
since splitsnapshots
unifiedsplit
@@ -1,61 +1,18 @@
1−{-# LANGUAGE DataKinds #-}
1+module Main where
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
2
11−{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
3+import Criterion.Main (defaultMain)
12
4
13−import Criterion.Main (bench, defaultMain, nf, whnf)
5+import Map (benchMap, prepareBenchMap)
14−
6+import OptimalVector (benchVectorOpt, prepareBenchVectorOpt)
15−import Prelude hiding (lookup)
7+--import Vector (benchVector, prepareBenchVector)
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)
25
8
26main :: IO ()
9main :: IO ()
27main = do
10main = do
28− putStrLn $ "size: " ++ (show $ size bigMap)
11+ prepareBenchMap
29− evaluate $ rknf bigMap
12+ --prepareBenchVector
13+ prepareBenchVectorOpt
30− defaultMain
14+ defaultMain
31− [ bench "lookup" $ nf tenLookups bigMap
15+ [ benchMap
32− , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
16+ -- , benchVector
33− , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
17+ , benchVectorOpt
34− ]
18+ ]
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))
benchmark/Map.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExplicitForAll #-}
3+{-# LANGUAGE ExplicitNamespaces #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
12+
13+module Map
14+ ( benchMap
15+ , prepareBenchMap
16+ ) where
17+
18+import Criterion.Main (Benchmark, bench, bgroup, nf)
19+
20+import Prelude hiding (lookup)
21+
22+import Control.Exception
23+import Control.DeepSeq (rnf)
24+import Data.Maybe (fromJust)
25+import Data.Proxy (Proxy (..))
26+import Data.Typeable (Typeable)
27+import GHC.TypeLits
28+
29+import Data.TypeRep.Map (TypeRepMap (..), empty, insert, lookup, keys)
30+
31+benchMap :: Benchmark
32+benchMap = bgroup "map"
33+ [ bench "lookup" $ nf tenLookups bigMap
34+ --, bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
35+ --, bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
36+ ]
37+
38+tenLookups :: TypeRepMap (Proxy :: Nat -> *)
39+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80
41+ )
42+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
43+ where
44+ lp :: forall (a::Nat). Typeable a => Proxy a
45+ lp = fromJust $ lookup tmap
46+
47+-- TypeRepMap of 10000 elements
48+bigMap :: TypeRepMap (Proxy :: Nat -> *)
49+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty
50+
51+buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *)
52+buildBigMap 1 x = insert x
53+buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
54+
55+rknf :: TypeRepMap f -> ()
56+rknf = rnf . keys
57+
58+prepareBenchMap :: IO ()
59+prepareBenchMap = evaluate (rknf bigMap)
benchmark/OptimalVector.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExplicitNamespaces #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
11+
12+module OptimalVector
13+ ( benchVectorOpt
14+ , prepareBenchVectorOpt
15+ ) where
16+
17+import Criterion.Main (Benchmark, bench, bgroup, nf)
18+
19+import Prelude hiding (lookup)
20+
21+import Control.Exception
22+import Control.DeepSeq (rnf)
23+import Data.Maybe (fromJust)
24+import Data.Proxy (Proxy (..))
25+import Data.Typeable (Typeable)
26+import GHC.TypeLits
27+
28+import Data.TypeRep.OptimalVector
29+
30+benchVectorOpt :: Benchmark
31+benchVectorOpt = bgroup "vector optimal"
32+ [ bench "lookup" $ nf tenLookups bigMap
33+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
34+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
35+ ]
36+
37+tenLookups :: TypeRepVector (Proxy :: Nat -> *)
38+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
39+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80
40+ )
41+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
42+ where
43+ lp :: forall (a::Nat). Typeable a => Proxy a
44+ lp = fromJust $ lookup tmap
45+
46+-- TypeRepMap of 10000 elements
47+bigMap :: TypeRepVector (Proxy :: Nat -> *)
48+bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []
49+
50+buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> [TF (Proxy :: Nat -> *)] -> [TF (Proxy :: Nat -> *)]
51+buildBigMap 1 x = (TF x :)
52+buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
53+
54+rknf :: TypeRepVector f -> ()
55+rknf tVect = rnf (fingerprintAs tVect, fingerprintBs tVect)
56+
57+prepareBenchVectorOpt :: IO ()
58+prepareBenchVectorOpt = evaluate (rknf bigMap)
benchmark/Vector.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExplicitNamespaces #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
11+
12+module Vector
13+ ( benchVector
14+ , prepareBenchVector
15+ ) where
16+
17+import Criterion.Main (Benchmark, bench, bgroup, nf)
18+
19+import Prelude hiding (lookup)
20+
21+import Control.Exception
22+import Control.DeepSeq (rnf)
23+import Data.Maybe (fromJust)
24+import Data.Proxy (Proxy (..))
25+import Data.Typeable (Typeable)
26+import GHC.TypeLits
27+
28+import Data.TypeRep.Vector
29+
30+benchVector :: Benchmark
31+benchVector = bgroup "vector"
32+ [ bench "lookup" $ nf tenLookups bigMap
33+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)
34+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)
35+ ]
36+
37+tenLookups :: TypeRepVector (Proxy :: Nat -> *)
38+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40
39+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80
40+ )
41+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)
42+ where
43+ lp :: forall (a::Nat). Typeable a => Proxy a
44+ lp = fromJust $ lookup tmap
45+
46+-- TypeRepMap of 10000 elements
47+bigMap :: TypeRepVector (Proxy :: Nat -> *)
48+bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []
49+
50+buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> [TF (Proxy :: Nat -> *)] -> [TF (Proxy :: Nat -> *)]
51+buildBigMap 1 x = (TF x :)
52+buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
53+
54+rknf :: TypeRepVector f -> ()
55+rknf = rnf . fingerprints
56+
57+prepareBenchVector :: IO ()
58+prepareBenchVector = evaluate (rknf bigMap)
src/Data/TypeRep/OptimalVector.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE ExplicitForAll #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MagicHash #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+
13+
14+module Data.TypeRep.OptimalVector
15+ ( TypeRepVector (..)
16+ , TF (..)
17+ , empty
18+ , insert
19+ , lookup
20+ , size
21+ , fromList
22+ ) where
23+
24+import Prelude hiding (lookup)
25+
26+import Control.Arrow ((&&&))
27+import Data.Proxy (Proxy (..))
28+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
29+import Data.Word (Word64)
30+import GHC.Base hiding (empty)
31+import GHC.Exts (sortWith)
32+import GHC.Fingerprint (Fingerprint (..))
33+import Unsafe.Coerce (unsafeCoerce)
34+import Debug.Trace
35+
36+import qualified Data.Vector as V
37+import qualified Data.Vector.Unboxed as Unboxed
38+
39+data TypeRepVector f = TypeRepVect
40+ { fingerprintAs :: Unboxed.Vector Word64
41+ , fingerprintBs :: Unboxed.Vector Word64
42+ , anys :: V.Vector Any
43+ }
44+
45+fromAny :: Any -> f a
46+fromAny = unsafeCoerce
47+
48+-- | Empty structure.
49+empty :: TypeRepVector f
50+empty = TypeRepVect mempty mempty mempty
51+
52+-- | Inserts the value with its type as a key.
53+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
54+insert = undefined
55+
56+-- | Looks up the value at the type.
57+-- >>> let x = lookup $ insert (11 :: Int) empty
58+-- >>> x :: Maybe Int
59+-- Just 11
60+-- >>> x :: Maybe ()
61+-- Nothing
62+lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
63+lookup tVect = fromAny . (anys tVect V.!)
64+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprintAs tVect) (fingerprintBs tVect)
65+
66+-- | Returns the size of the 'TypeRepVect'.
67+size :: TypeRepVector f -> Int
68+size = Unboxed.length . fingerprintAs
69+
70+data TF f where
71+ TF :: Typeable a => f a -> TF f
72+
73+fromF :: Typeable a => f a -> Proxy a
74+fromF _ = Proxy
75+
76+fromList :: forall f . [TF f] -> TypeRepVector f
77+fromList tfs = TypeRepVect (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
78+ where
79+ (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps
80+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs
81+
82+ fp :: TF f -> Fingerprint
83+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x
84+
85+ an :: TF f -> Any
86+ an (TF x) = unsafeCoerce x
87+
88+-- | Returns the index is found.
89+binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
90+binarySearch (Fingerprint a b) fpAs fpBs =
91+ let
92+ !(I# len) = Unboxed.length fpAs
93+ checkfpBs :: Int# -> Maybe Int
94+ checkfpBs i =
95+ case i <# len of
96+ 0# -> Nothing
97+ _ ->
98+ if a /= Unboxed.unsafeIndex fpAs (I# i)
99+ then Nothing
100+ else if b == Unboxed.unsafeIndex fpBs (I# i)
101+ then Just (I# i)
102+ else checkfpBs (i +# 1#)
103+ in
104+ inline (checkfpBs (binSearchHelp (-1#) len))
105+ where
106+ binSearchHelp :: Int# -> Int# -> Int#
107+ binSearchHelp l r = case l <# (r -# 1#) of
108+ 0# -> r
109+ _ ->
110+ let m = uncheckedIShiftRA# (l +# r) 1# in
111+ if Unboxed.unsafeIndex fpAs (I# m) < a
112+ then binSearchHelp m r
113+ else binSearchHelp l m
114+
src/Data/TypeRep/Vector.hsnew file+195
@@ -0,0 +1,195 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+{-# LANGUAGE ExplicitForAll #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE MagicHash, BangPatterns #-}
13+
14+
15+module Data.TypeRep.Vector
16+ ( TypeRepVector (..)
17+ , TF (..)
18+ , empty
19+ , insert
20+ , lookup
21+ , size
22+ , fromList
23+ ) where
24+
25+import Prelude hiding (lookup)
26+
27+import Control.Arrow ((&&&))
28+import Data.Proxy (Proxy (..))
29+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
30+import Data.Word (Word64)
31+import GHC.Base hiding (empty)
32+import GHC.Exts (sortWith)
33+import GHC.Fingerprint (Fingerprint (..))
34+import Unsafe.Coerce (unsafeCoerce)
35+import Control.Monad.ST
36+import GHC.Prim
37+
38+import qualified Data.Vector as V
39+import qualified Data.Vector.Generic as G
40+import qualified Data.Vector.Generic.Mutable as M
41+import qualified Data.Vector.Unboxed as Unboxed
42+
43+data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
44+data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)
45+
46+instance Unboxed.Unbox Fingerprint
47+
48+instance M.MVector Unboxed.MVector Fingerprint where
49+ {-# INLINE basicLength #-}
50+ basicLength (MFingerprintVector x _) = M.basicLength x
51+ {-# INLINE basicUnsafeSlice #-}
52+ basicUnsafeSlice i m (MFingerprintVector a b) =
53+ MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)
54+ {-# INLINE basicOverlaps #-}
55+ basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) =
56+ M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
57+ {-# INLINE basicUnsafeNew #-}
58+ basicUnsafeNew n_ = do
59+ as <- M.basicUnsafeNew n_
60+ bs <- M.basicUnsafeNew n_
61+ return $ MFingerprintVector as bs
62+ {-# INLINE basicInitialize #-}
63+ basicInitialize (MFingerprintVector as bs) = do
64+ M.basicInitialize as
65+ M.basicInitialize bs
66+ {-# INLINE basicUnsafeReplicate #-}
67+ basicUnsafeReplicate n_ (Fingerprint a b) = do
68+ as <- M.basicUnsafeReplicate n_ a
69+ bs <- M.basicUnsafeReplicate n_ b
70+ return $ MFingerprintVector as bs
71+ {-# INLINE basicUnsafeRead #-}
72+ basicUnsafeRead (MFingerprintVector as bs) i_ = do
73+ a <- M.basicUnsafeRead as i_
74+ b <- M.basicUnsafeRead bs i_
75+ return (Fingerprint a b)
76+ {-# INLINE basicUnsafeWrite #-}
77+ basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do
78+ M.basicUnsafeWrite as i_ a
79+ M.basicUnsafeWrite bs i_ b
80+ {-# INLINE basicClear #-}
81+ basicClear (MFingerprintVector as bs) = do
82+ M.basicClear as
83+ M.basicClear bs
84+ {-# INLINE basicSet #-}
85+ basicSet (MFingerprintVector as bs) (Fingerprint a b) = do
86+ M.basicSet as a
87+ M.basicSet bs b
88+ {-# INLINE basicUnsafeCopy #-}
89+ basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
90+ M.basicUnsafeCopy as1 as2
91+ M.basicUnsafeCopy bs1 bs2
92+ {-# INLINE basicUnsafeMove #-}
93+ basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
94+ M.basicUnsafeMove as1 as2
95+ M.basicUnsafeMove bs1 bs2
96+ {-# INLINE basicUnsafeGrow #-}
97+ basicUnsafeGrow (MFingerprintVector as bs) m_ = do
98+ as' <- M.basicUnsafeGrow as m_
99+ bs' <- M.basicUnsafeGrow bs m_
100+ return $ MFingerprintVector as' bs'
101+
102+instance G.Vector Unboxed.Vector Fingerprint where
103+ {-# INLINE basicUnsafeFreeze #-}
104+ basicUnsafeFreeze (MFingerprintVector as bs) = do
105+ as' <- G.basicUnsafeFreeze as
106+ bs' <- G.basicUnsafeFreeze bs
107+ return $ FingerprintVector as' bs'
108+ {-# INLINE basicUnsafeThaw #-}
109+ basicUnsafeThaw (FingerprintVector as bs) = do
110+ as' <- G.basicUnsafeThaw as
111+ bs' <- G.basicUnsafeThaw bs
112+ return $ MFingerprintVector as' bs'
113+ {-# INLINE basicLength #-}
114+ basicLength (FingerprintVector x _) = G.basicLength x
115+ {-# INLINE basicUnsafeSlice #-}
116+ basicUnsafeSlice i_ m_ (FingerprintVector as bs) =
117+ FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs)
118+ {-# INLINE basicUnsafeIndexM #-}
119+ basicUnsafeIndexM (FingerprintVector as bs) i_ = do
120+ a <- G.basicUnsafeIndexM as i_
121+ b <- G.basicUnsafeIndexM bs i_
122+ return (Fingerprint a b)
123+ {-# INLINE basicUnsafeCopy #-}
124+ basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do
125+ G.basicUnsafeCopy as1 as2
126+ G.basicUnsafeCopy bs1 bs2
127+ {-# INLINE elemseq #-}
128+ elemseq _ (Fingerprint a b)
129+ = G.elemseq (undefined :: Unboxed.Vector a) a
130+ . G.elemseq (undefined :: Unboxed.Vector b) b
131+
132+data TypeRepVector f = TypeRepVect
133+ { fingerprints :: Unboxed.Vector Fingerprint
134+ , anys :: V.Vector Any
135+ }
136+
137+fromAny :: Any -> f a
138+fromAny = unsafeCoerce
139+
140+-- | Empty structure.
141+empty :: TypeRepVector f
142+empty = TypeRepVect mempty mempty
143+
144+-- | Inserts the value with its type as a key.
145+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
146+insert = undefined
147+
148+-- | Looks up the value at the type.
149+-- >>> let x = lookup $ insert (11 :: Int) empty
150+-- >>> x :: Maybe Int
151+-- Just 11
152+-- >>> x :: Maybe ()
153+-- Nothing
154+lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
155+lookup tVect = fromAny . (anys tVect V.!)
156+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
157+
158+-- | Returns the size of the 'TypeRepVect'.
159+size :: TypeRepVector f -> Int
160+size = Unboxed.length . fingerprints
161+
162+data TF f where
163+ TF :: Typeable a => f a -> TF f
164+
165+fromF :: Typeable a => f a -> Proxy a
166+fromF _ = Proxy
167+
168+fromList :: forall f . [TF f] -> TypeRepVector f
169+fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)
170+ where
171+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs
172+
173+ fp :: TF f -> Fingerprint
174+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x
175+
176+ an :: TF f -> Any
177+ an (TF x) = unsafeCoerce x
178+
179+-- | Returns the index is found.
180+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
181+binarySearch fp fpVect =
182+ let
183+ !(I# len) = Unboxed.length fpVect
184+ ind = I# (binSearchHelp (-1#) len)
185+ in
186+ if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
187+ where
188+ binSearchHelp :: Int# -> Int# -> Int#
189+ binSearchHelp l r = case l <# (r -# 1#) of
190+ 0# -> r
191+ _ ->
192+ let m = uncheckedIShiftRA# (l +# r) 1# in
193+ if Unboxed.unsafeIndex fpVect (I# m) < fp
194+ then binSearchHelp m r
195+ else binSearchHelp l m
test/Test/TypeRep/Vector.hsnew file+41
@@ -0,0 +1,41 @@
1+module Test.TypeRep.Vector 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.Vector
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 (fromList [TF (Identity 'a')]) `shouldBe` Just (Identity 'a')
17+ it "returns the second inserted value of the same type" $
18+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `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
test/Test/TypeRep/VectorOpt.hsnew file+41
@@ -0,0 +1,41 @@
1+module Test.TypeRep.VectorOpt 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.OptimalVector
10+
11+-- Simple test for 'lookup', 'insert' and 'size' functions.
12+insertLookup :: Spec
13+insertLookup = do
14+ describe "Lookup Test" $ do
15+ it "returns the inserted element" $
16+ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a')
17+ it "returns the second inserted value of the same type" $
18+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `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+9
@@ -17,9 +17,13 @@ tested-with: GHC == 8.0.1
17library
17library
18 hs-source-dirs: src
18 hs-source-dirs: src
19 exposed-modules: Data.TypeRep.Map
19 exposed-modules: Data.TypeRep.Map
20+ , Data.TypeRep.Vector
21+ , Data.TypeRep.OptimalVector
20 ghc-options: -Wall
22 ghc-options: -Wall
21 build-depends: base
23 build-depends: base
22 , containers
24 , containers
25+ , vector
26+ , ghc-prim
23 default-language: Haskell2010
27 default-language: Haskell2010
24
28
25test-suite typerep-map-test
29test-suite typerep-map-test
@@ -27,6 +31,8 @@ test-suite typerep-map-test
27 hs-source-dirs: test
31 hs-source-dirs: test
28 main-is: Test.hs
32 main-is: Test.hs
29 other-modules: Test.TypeRep.Map
33 other-modules: Test.TypeRep.Map
34+ , Test.TypeRep.Vector
35+ , Test.TypeRep.VectorOpt
30 build-depends: base
36 build-depends: base
31 , typerep-map
37 , typerep-map
32 , tasty
38 , tasty
@@ -41,6 +47,9 @@ benchmark typerep-map-benchmark
41 ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0
47 ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0
42 hs-source-dirs: benchmark
48 hs-source-dirs: benchmark
43 main-is: Main.hs
49 main-is: Main.hs
50+ other-modules: Map
51+ , Vector
52+ , OptimalVector
44 build-depends: base
53 build-depends: base
45 , criterion
54 , criterion
46 , typerep-map
55 , typerep-map