git.iko.soy/typerep-map
on main help sign in
Write Unbox instance for Fingerprint
e09c86cvrom911
src/Data/TypeRep/Vector.hs+120−17
compare with main
unifiedsplit
@@ -1,8 +1,11 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
1−{-# LANGUAGE ExplicitForAll #-}
3+{-# LANGUAGE ExplicitForAll #-}
2−{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeFamilies #-}
6
9
7
10
8module Data.TypeRep.Vector
11module Data.TypeRep.Vector
@@ -16,27 +19,128 @@ module Data.TypeRep.Vector
16import Prelude hiding (lookup)
19import Prelude hiding (lookup)
17
20
18import Data.Proxy (Proxy (..))
21import Data.Proxy (Proxy (..))
19−import Data.Typeable (TypeRep, Typeable, typeRep, typeRepFingerprint)
22+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
20import Data.Word (Word64)
23import Data.Word (Word64)
21import GHC.Base (Any)
24import GHC.Base (Any)
22import GHC.Fingerprint (Fingerprint (..))
25import GHC.Fingerprint (Fingerprint (..))
23import Unsafe.Coerce (unsafeCoerce)
26import Unsafe.Coerce (unsafeCoerce)
24
27
25import qualified Data.Vector as V
28import qualified Data.Vector as V
29+import qualified Data.Vector.Generic as G
30+import qualified Data.Vector.Generic.Mutable as M
26import qualified Data.Vector.Unboxed as Unboxed
31import qualified Data.Vector.Unboxed as Unboxed
27
32
28−type FingerprintPair = (Word64, Word64)
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)
35+
36+instance Unboxed.Unbox Fingerprint
37+
38+instance M.MVector Unboxed.MVector Fingerprint where
39+ {-# INLINE basicLength #-}
40+ basicLength (MFingerprintVector n _ _) = n
41+ {-# INLINE basicUnsafeSlice #-}
42+ basicUnsafeSlice i m (MFingerprintVector _ a b) =
43+ MFingerprintVector m (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)
44+ {-# INLINE basicOverlaps #-}
45+ basicOverlaps (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2) =
46+ M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
47+ {-# INLINE basicUnsafeNew #-}
48+ basicUnsafeNew n_
49+ = do
50+ as <- M.basicUnsafeNew n_
51+ bs <- M.basicUnsafeNew n_
52+ return $ MFingerprintVector n_ as bs
53+ {-# INLINE basicInitialize #-}
54+ basicInitialize (MFingerprintVector _ as bs)
55+ = do
56+ M.basicInitialize as
57+ M.basicInitialize bs
58+ {-# 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
64+ {-# 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)
70+ {-# 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
75+ {-# INLINE basicClear #-}
76+ basicClear (MFingerprintVector _ as bs)
77+ = do
78+ M.basicClear as
79+ M.basicClear bs
80+ {-# INLINE basicSet #-}
81+ basicSet (MFingerprintVector _ as bs) (Fingerprint a b)
82+ = do
83+ M.basicSet as a
84+ M.basicSet bs b
85+ {-# INLINE basicUnsafeCopy #-}
86+ basicUnsafeCopy (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2)
87+ = do
88+ M.basicUnsafeCopy as1 as2
89+ M.basicUnsafeCopy bs1 bs2
90+ {-# INLINE basicUnsafeMove #-}
91+ basicUnsafeMove (MFingerprintVector _ as1 bs1) (MFingerprintVector _ as2 bs2)
92+ = do
93+ M.basicUnsafeMove as1 as2
94+ M.basicUnsafeMove bs1 bs2
95+ {-# 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'
101+
102+instance G.Vector Unboxed.Vector Fingerprint where
103+ {-# 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'
109+ {-# 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'
115+ {-# INLINE basicLength #-}
116+ basicLength (FingerprintVector n_ _ _) = n_
117+ {-# INLINE basicUnsafeSlice #-}
118+ basicUnsafeSlice i_ m_ (FingerprintVector _ as bs)
119+ = FingerprintVector m_ (G.basicUnsafeSlice i_ m_ as)
120+ (G.basicUnsafeSlice i_ m_ bs)
121+ {-# 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)
127+ {-# INLINE basicUnsafeCopy #-}
128+ basicUnsafeCopy (MFingerprintVector _ as1 bs1) (FingerprintVector _ as2 bs2)
129+ = do
130+ G.basicUnsafeCopy as1 as2
131+ G.basicUnsafeCopy bs1 bs2
132+ {-# INLINE elemseq #-}
133+ elemseq _ (Fingerprint a b)
134+ = G.elemseq (undefined :: Unboxed.Vector a) a
135+ . G.elemseq (undefined :: Unboxed.Vector b) b
29
136
30data TypeRepVector f = TypeRepVect
137data TypeRepVector f = TypeRepVect
31− { fingerprints :: Unboxed.Vector FingerprintPair
138+ { fingerprints :: Unboxed.Vector Fingerprint
32 , anys :: V.Vector Any
139 , anys :: V.Vector Any
33 }
140 }
34
141
35−fromFingerprint :: Fingerprint -> FingerprintPair
142+fromAny :: Any -> f a
36−fromFingerprint (Fingerprint x y) = (x, y)
143+fromAny = unsafeCoerce
37−
38−typeRepToPair :: TypeRep -> FingerprintPair
39−typeRepToPair = fromFingerprint . typeRepFingerprint
40
144
41-- | Empty structure.
145-- | Empty structure.
42empty :: TypeRepVector f
146empty :: TypeRepVector f
@@ -53,16 +157,15 @@ insert = undefined
53-- >>> x :: Maybe ()
157-- >>> x :: Maybe ()
54-- Nothing
158-- Nothing
55lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
159lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
160+lookup tVect = fromAny . (anys tVect V.!)
56−lookup tVect = case binarySearch (typeRepToPair (typeRep (Proxy :: Proxy a))) (fingerprints tVect) of
161+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
57− Just ind -> Just $ unsafeCoerce $ (anys tVect) V.! ind
58− Nothing -> Nothing
59
162
60-- | Returns the size of the 'TypeRepVect'.
163-- | Returns the size of the 'TypeRepVect'.
61size :: TypeRepVector f -> Int
164size :: TypeRepVector f -> Int
62size = Unboxed.length . fingerprints
165size = Unboxed.length . fingerprints
63
166
64-- | Returns the index is found.
167-- | Returns the index is found.
65−binarySearch :: FingerprintPair -> Unboxed.Vector FingerprintPair -> Maybe Int
168+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
66binarySearch fp fpVect =
169binarySearch fp fpVect =
67 let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
170 let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
68 if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
171 if fp == (fpVect Unboxed.! ind) then Just ind else Nothing