git.iko.soy/typerep-map
on main help sign in
Add Unbox instance Fingerprint on 1 Vector, bench
commitfde78a62f3ab908e36cc3c272f981443d1972ef7 authorvrom911 <vrom911@gmail.com> dateTue 19 Dec 2017, 04:51 (9 years ago) parente09c86c
9 files changed+536−131
compare with main
unifiedsplit
benchmark/Main.hs+10−57 benchmark/Map.hs+61 benchmark/OptimalVector.hs+59 benchmark/Vector.hs+59 src/Data/TypeRep/OptimalVector.hs+177 src/Data/TypeRep/Vector.hs+82−74 test/Test/TypeRep/Vector.hs+41 test/Test/TypeRep/VectorOpt.hs+41 typerep-map.cabal+6
benchmark/Main.hs+10−57
@@ -1,61 +1,14 @@
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 #-}
1+module Main where
102
11−{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
3+import Criterion.Main (defaultMain)
124
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)
5+import Map (benchMap)
6+import OptimalVector (benchVectorOpt)
7+--import Vector (benchVector)
258
269main :: IO ()
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))
10+main = defaultMain
11+ [ benchMap
12+ --, benchVector
13+ , benchVectorOpt
14+ ]
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 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22
33{-# LANGUAGE ExplicitForAll #-}
4+{-# LANGUAGE GADTs #-}
45{-# LANGUAGE KindSignatures #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE RankNTypes #-}
79{-# LANGUAGE ScopedTypeVariables #-}
810{-# LANGUAGE TypeFamilies #-}
911
1012
1113module Data.TypeRep.Vector
1214 ( TypeRepVector (..)
15+ , TF (..)
1316 , empty
1417 , insert
1518 , lookup
1619 , size
20+ , fromList
1721 ) where
1822
1923import Prelude hiding (lookup)
2024
25+import Control.Arrow ((&&&))
2126import Data.Proxy (Proxy (..))
2227import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
2328import Data.Word (Word64)
2429import GHC.Base (Any)
30+import GHC.Exts (sortWith)
2531import GHC.Fingerprint (Fingerprint (..))
2632import Unsafe.Coerce (unsafeCoerce)
2733
@@ -30,105 +36,90 @@ import qualified Data.Vector.Generic as G
3036import qualified Data.Vector.Generic.Mutable as M
3137import qualified Data.Vector.Unboxed as Unboxed
3238
33−data instance Unboxed.MVector s Fingerprint = MFingerprintVector !Int (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
34−data instance Unboxed.Vector Fingerprint = FingerprintVector !Int (Unboxed.Vector Word64) (Unboxed.Vector Word64)
39+data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
40+data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)
3541
3642instance Unboxed.Unbox Fingerprint
3743
3844instance M.MVector Unboxed.MVector Fingerprint where
3945 {-# INLINE basicLength #-}
40− basicLength (MFingerprintVector n _ _) = n
46+ basicLength (MFingerprintVector x _) = M.basicLength x
4147 {-# INLINE basicUnsafeSlice #-}
42− basicUnsafeSlice i m (MFingerprintVector _ a b) =
43− MFingerprintVector m (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)
48+ basicUnsafeSlice i m (MFingerprintVector a b) =
49+ MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)
4450 {-# INLINE basicOverlaps #-}
45− basicOverlaps (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2) =
51+ basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) =
4652 M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
4753 {-# INLINE basicUnsafeNew #-}
48− basicUnsafeNew n_
49− = do
50− as <- M.basicUnsafeNew n_
51− bs <- M.basicUnsafeNew n_
52− return $ MFingerprintVector n_ as bs
54+ basicUnsafeNew n_ = do
55+ as <- M.basicUnsafeNew n_
56+ bs <- M.basicUnsafeNew n_
57+ return $ MFingerprintVector as bs
5358 {-# INLINE basicInitialize #-}
54− basicInitialize (MFingerprintVector _ as bs)
55− = do
56− M.basicInitialize as
57− M.basicInitialize bs
59+ basicInitialize (MFingerprintVector as bs) = do
60+ M.basicInitialize as
61+ M.basicInitialize bs
5862 {-# INLINE basicUnsafeReplicate #-}
59− basicUnsafeReplicate n_ (Fingerprint a b)
60− = do
61− as <- M.basicUnsafeReplicate n_ a
62− bs <- M.basicUnsafeReplicate n_ b
63− return $ MFingerprintVector n_ as bs
63+ basicUnsafeReplicate n_ (Fingerprint a b) = do
64+ as <- M.basicUnsafeReplicate n_ a
65+ bs <- M.basicUnsafeReplicate n_ b
66+ return $ MFingerprintVector as bs
6467 {-# INLINE basicUnsafeRead #-}
65− basicUnsafeRead (MFingerprintVector _ as bs) i_
66− = do
67− a <- M.basicUnsafeRead as i_
68− b <- M.basicUnsafeRead bs i_
69− return (Fingerprint a b)
68+ basicUnsafeRead (MFingerprintVector as bs) i_ = do
69+ a <- M.basicUnsafeRead as i_
70+ b <- M.basicUnsafeRead bs i_
71+ return (Fingerprint a b)
7072 {-# INLINE basicUnsafeWrite #-}
71− basicUnsafeWrite (MFingerprintVector _ as bs) i_ (Fingerprint a b)
72− = do
73− M.basicUnsafeWrite as i_ a
74− M.basicUnsafeWrite bs i_ b
73+ basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do
74+ M.basicUnsafeWrite as i_ a
75+ M.basicUnsafeWrite bs i_ b
7576 {-# INLINE basicClear #-}
76− basicClear (MFingerprintVector _ as bs)
77− = do
78− M.basicClear as
79− M.basicClear bs
77+ basicClear (MFingerprintVector as bs) = do
78+ M.basicClear as
79+ M.basicClear bs
8080 {-# INLINE basicSet #-}
81− basicSet (MFingerprintVector _ as bs) (Fingerprint a b)
82− = do
83− M.basicSet as a
84− M.basicSet bs b
81+ basicSet (MFingerprintVector as bs) (Fingerprint a b) = do
82+ M.basicSet as a
83+ M.basicSet bs b
8584 {-# INLINE basicUnsafeCopy #-}
86− basicUnsafeCopy (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2)
87− = do
88− M.basicUnsafeCopy as1 as2
89− M.basicUnsafeCopy bs1 bs2
85+ basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
86+ M.basicUnsafeCopy as1 as2
87+ M.basicUnsafeCopy bs1 bs2
9088 {-# INLINE basicUnsafeMove #-}
91− basicUnsafeMove (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2)
92− = do
93− M.basicUnsafeMove as1 as2
94− M.basicUnsafeMove bs1 bs2
89+ basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
90+ M.basicUnsafeMove as1 as2
91+ M.basicUnsafeMove bs1 bs2
9592 {-# INLINE basicUnsafeGrow #-}
96− basicUnsafeGrow (MFingerprintVector n_ as bs) m_
97− = do
98− as' <- M.basicUnsafeGrow as m_
99− bs' <- M.basicUnsafeGrow bs m_
100− return $ MFingerprintVector (m_ + n_) as' bs'
93+ basicUnsafeGrow (MFingerprintVector as bs) m_ = do
94+ as' <- M.basicUnsafeGrow as m_
95+ bs' <- M.basicUnsafeGrow bs m_
96+ return $ MFingerprintVector as' bs'
10197
10298instance G.Vector Unboxed.Vector Fingerprint where
10399 {-# INLINE basicUnsafeFreeze #-}
104− basicUnsafeFreeze (MFingerprintVector n_ as bs)
105− = do
106− as' <- G.basicUnsafeFreeze as
107− bs' <- G.basicUnsafeFreeze bs
108− return $ FingerprintVector n_ as' bs'
100+ basicUnsafeFreeze (MFingerprintVector as bs) = do
101+ as' <- G.basicUnsafeFreeze as
102+ bs' <- G.basicUnsafeFreeze bs
103+ return $ FingerprintVector as' bs'
109104 {-# INLINE basicUnsafeThaw #-}
110− basicUnsafeThaw (FingerprintVector n_ as bs)
111− = do
112− as' <- G.basicUnsafeThaw as
113− bs' <- G.basicUnsafeThaw bs
114− return $ MFingerprintVector n_ as' bs'
105+ basicUnsafeThaw (FingerprintVector as bs) = do
106+ as' <- G.basicUnsafeThaw as
107+ bs' <- G.basicUnsafeThaw bs
108+ return $ MFingerprintVector as' bs'
115109 {-# INLINE basicLength #-}
116− basicLength (FingerprintVector n_ _ _) = n_
110+ basicLength (FingerprintVector x _) = G.basicLength x
117111 {-# INLINE basicUnsafeSlice #-}
118− basicUnsafeSlice i_ m_ (FingerprintVector _ as bs)
119− = FingerprintVector m_ (G.basicUnsafeSlice i_ m_ as)
120− (G.basicUnsafeSlice i_ m_ bs)
112+ basicUnsafeSlice i_ m_ (FingerprintVector as bs) =
113+ FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs)
121114 {-# INLINE basicUnsafeIndexM #-}
122− basicUnsafeIndexM (FingerprintVector _ as bs) i_
123− = do
124− a <- G.basicUnsafeIndexM as i_
125− b <- G.basicUnsafeIndexM bs i_
126− return (Fingerprint a b)
115+ basicUnsafeIndexM (FingerprintVector as bs) i_ = do
116+ a <- G.basicUnsafeIndexM as i_
117+ b <- G.basicUnsafeIndexM bs i_
118+ return (Fingerprint a b)
127119 {-# INLINE basicUnsafeCopy #-}
128− basicUnsafeCopy (MFingerprintVector _ as1 bs1) (FingerprintVector _ as2 bs2)
129− = do
130− G.basicUnsafeCopy as1 as2
131− G.basicUnsafeCopy bs1 bs2
120+ basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do
121+ G.basicUnsafeCopy as1 as2
122+ G.basicUnsafeCopy bs1 bs2
132123 {-# INLINE elemseq #-}
133124 elemseq _ (Fingerprint a b)
134125 = G.elemseq (undefined :: Unboxed.Vector a) a
@@ -153,7 +144,7 @@ insert = undefined
153144-- | Looks up the value at the type.
154145-- >>> let x = lookup $ insert (11 :: Int) empty
155146-- >>> x :: Maybe Int
156−-- Just 11
147+-- Just 11a Ty
157148-- >>> x :: Maybe ()
158149-- Nothing
159150lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
@@ -164,6 +155,23 @@ lookup tVect = fromAny . (anys tVect V.!)
164155size :: TypeRepVector f -> Int
165156size = Unboxed.length . fingerprints
166157
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+
167175-- | Returns the index is found.
168176binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
169177binarySearch 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
1818 hs-source-dirs: src
1919 exposed-modules: Data.TypeRep.Map
2020 , Data.TypeRep.Vector
21+ , Data.TypeRep.OptimalVector
2122 ghc-options: -Wall
2223 build-depends: base
2324 , containers
@@ -29,6 +30,8 @@ test-suite typerep-map-test
2930 hs-source-dirs: test
3031 main-is: Test.hs
3132 other-modules: Test.TypeRep.Map
33+ , Test.TypeRep.Vector
34+ , Test.TypeRep.VectorOpt
3235 build-depends: base
3336 , typerep-map
3437 , tasty
@@ -43,6 +46,9 @@ benchmark typerep-map-benchmark
4346 ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0
4447 hs-source-dirs: benchmark
4548 main-is: Main.hs
49+ other-modules: Map
50+ , Vector
51+ , OptimalVector
4652 build-depends: base
4753 , criterion
4854 , typerep-map