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