@@ -0,0 +1,180 @@
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 #-}
9+
10+
11+module Data.TypeRep.Vector
12+ ( TypeRepVector (..)
13+ , empty
14+ , insert
15+ , lookup
16+ , size
17+ ) where
18+
19+import Prelude hiding (lookup)
20+
21+import Data.Proxy (Proxy (..))
22+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
23+import Data.Word (Word64)
24+import GHC.Base (Any)
25+import GHC.Fingerprint (Fingerprint (..))
26+import Unsafe.Coerce (unsafeCoerce)
27+
28+import qualified Data.Vector as V
29+import qualified Data.Vector.Generic as G
30+import qualified Data.Vector.Generic.Mutable as M
31+import qualified Data.Vector.Unboxed as Unboxed
32+
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
136+
137+data TypeRepVector f = TypeRepVect
138+ { fingerprints :: Unboxed.Vector Fingerprint
139+ , anys :: V.Vector Any
140+ }
141+
142+fromAny :: Any -> f a
143+fromAny = unsafeCoerce
144+
145+-- | Empty structure.
146+empty :: TypeRepVector f
147+empty = TypeRepVect mempty mempty
148+
149+-- | Inserts the value with its type as a key.
150+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
151+insert = undefined
152+
153+-- | Looks up the value at the type.
154+-- >>> let x = lookup $ insert (11 :: Int) empty
155+-- >>> x :: Maybe Int
156+-- Just 11
157+-- >>> x :: Maybe ()
158+-- Nothing
159+lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
160+lookup tVect = fromAny . (anys tVect V.!)
161+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
162+
163+-- | Returns the size of the 'TypeRepVect'.
164+size :: TypeRepVector f -> Int
165+size = Unboxed.length . fingerprints
166+
167+-- | Returns the index is found.
168+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
169+binarySearch fp fpVect =
170+ let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
171+ if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
172+ where
173+ binSearchHelp :: Int -> Int -> Int
174+ binSearchHelp l r = if l < r - 1
175+ then (
176+ let m = (l + r) `div` 2 in
177+ if fpVect Unboxed.! m < fp
178+ then binSearchHelp m r
179+ else binSearchHelp l m )
180+ else r