@@ -1,8 +1,11 @@
1−{-# LANGUAGE ExplicitForAll #-}
2−{-# LANGUAGE KindSignatures #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeFamilies #-}
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+{-# LANGUAGE ExplicitForAll #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
69
710
811module Data.TypeRep.Vector
@@ -16,27 +19,128 @@ module Data.TypeRep.Vector
1619import Prelude hiding (lookup)
1720
1821import Data.Proxy (Proxy (..))
19−import Data.Typeable (TypeRep, Typeable, typeRep, typeRepFingerprint)
22+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
2023import Data.Word (Word64)
2124import GHC.Base (Any)
2225import GHC.Fingerprint (Fingerprint (..))
2326import Unsafe.Coerce (unsafeCoerce)
2427
2528import qualified Data.Vector as V
29+import qualified Data.Vector.Generic as G
30+import qualified Data.Vector.Generic.Mutable as M
2631import qualified Data.Vector.Unboxed as Unboxed
2732
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
29136
30137data TypeRepVector f = TypeRepVect
31− { fingerprints :: Unboxed.Vector FingerprintPair
138+ { fingerprints :: Unboxed.Vector Fingerprint
32139 , anys :: V.Vector Any
33140 }
34141
35−fromFingerprint :: Fingerprint -> FingerprintPair
36−fromFingerprint (Fingerprint x y) = (x, y)
37−
38−typeRepToPair :: TypeRep -> FingerprintPair
39−typeRepToPair = fromFingerprint . typeRepFingerprint
142+fromAny :: Any -> f a
143+fromAny = unsafeCoerce
40144
41145-- | Empty structure.
42146empty :: TypeRepVector f
@@ -53,16 +157,15 @@ insert = undefined
53157-- >>> x :: Maybe ()
54158-- Nothing
55159lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
56−lookup tVect = case binarySearch (typeRepToPair (typeRep (Proxy :: Proxy a))) (fingerprints tVect) of
57− Just ind -> Just $ unsafeCoerce $ (anys tVect) V.! ind
58− Nothing -> Nothing
160+lookup tVect = fromAny . (anys tVect V.!)
161+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
59162
60163-- | Returns the size of the 'TypeRepVect'.
61164size :: TypeRepVector f -> Int
62165size = Unboxed.length . fingerprints
63166
64167-- | Returns the index is found.
65−binarySearch :: FingerprintPair -> Unboxed.Vector FingerprintPair -> Maybe Int
168+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
66169binarySearch fp fpVect =
67170 let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
68171 if fp == (fpVect Unboxed.! ind) then Just ind else Nothing