@@ -0,0 +1,188 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+{-# LANGUAGE ExplicitForAll #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+
12+
13+module Data.TypeRep.Vector
14+ ( TypeRepVector (..)
15+ , TF (..)
16+ , empty
17+ , insert
18+ , lookup
19+ , size
20+ , fromList
21+ ) where
22+
23+import Prelude hiding (lookup)
24+
25+import Control.Arrow ((&&&))
26+import Data.Proxy (Proxy (..))
27+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
28+import Data.Word (Word64)
29+import GHC.Base (Any)
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 = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
40+data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)
41+
42+instance Unboxed.Unbox Fingerprint
43+
44+instance M.MVector Unboxed.MVector Fingerprint where
45+ {-# INLINE basicLength #-}
46+ basicLength (MFingerprintVector x _) = M.basicLength x
47+ {-# INLINE basicUnsafeSlice #-}
48+ basicUnsafeSlice i m (MFingerprintVector a b) =
49+ MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)
50+ {-# INLINE basicOverlaps #-}
51+ basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) =
52+ M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
53+ {-# INLINE basicUnsafeNew #-}
54+ basicUnsafeNew n_ = do
55+ as <- M.basicUnsafeNew n_
56+ bs <- M.basicUnsafeNew n_
57+ return $ MFingerprintVector as bs
58+ {-# INLINE basicInitialize #-}
59+ basicInitialize (MFingerprintVector as bs) = do
60+ M.basicInitialize as
61+ M.basicInitialize bs
62+ {-# INLINE basicUnsafeReplicate #-}
63+ basicUnsafeReplicate n_ (Fingerprint a b) = do
64+ as <- M.basicUnsafeReplicate n_ a
65+ bs <- M.basicUnsafeReplicate n_ b
66+ return $ MFingerprintVector as bs
67+ {-# INLINE basicUnsafeRead #-}
68+ basicUnsafeRead (MFingerprintVector as bs) i_ = do
69+ a <- M.basicUnsafeRead as i_
70+ b <- M.basicUnsafeRead bs i_
71+ return (Fingerprint a b)
72+ {-# INLINE basicUnsafeWrite #-}
73+ basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do
74+ M.basicUnsafeWrite as i_ a
75+ M.basicUnsafeWrite bs i_ b
76+ {-# INLINE basicClear #-}
77+ basicClear (MFingerprintVector as bs) = do
78+ M.basicClear as
79+ M.basicClear bs
80+ {-# INLINE basicSet #-}
81+ basicSet (MFingerprintVector as bs) (Fingerprint a b) = do
82+ M.basicSet as a
83+ M.basicSet bs b
84+ {-# INLINE basicUnsafeCopy #-}
85+ basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
86+ M.basicUnsafeCopy as1 as2
87+ M.basicUnsafeCopy bs1 bs2
88+ {-# INLINE basicUnsafeMove #-}
89+ basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do
90+ M.basicUnsafeMove as1 as2
91+ M.basicUnsafeMove bs1 bs2
92+ {-# INLINE basicUnsafeGrow #-}
93+ basicUnsafeGrow (MFingerprintVector as bs) m_ = do
94+ as' <- M.basicUnsafeGrow as m_
95+ bs' <- M.basicUnsafeGrow bs m_
96+ return $ MFingerprintVector as' bs'
97+
98+instance G.Vector Unboxed.Vector Fingerprint where
99+ {-# INLINE basicUnsafeFreeze #-}
100+ basicUnsafeFreeze (MFingerprintVector as bs) = do
101+ as' <- G.basicUnsafeFreeze as
102+ bs' <- G.basicUnsafeFreeze bs
103+ return $ FingerprintVector as' bs'
104+ {-# INLINE basicUnsafeThaw #-}
105+ basicUnsafeThaw (FingerprintVector as bs) = do
106+ as' <- G.basicUnsafeThaw as
107+ bs' <- G.basicUnsafeThaw bs
108+ return $ MFingerprintVector as' bs'
109+ {-# INLINE basicLength #-}
110+ basicLength (FingerprintVector x _) = G.basicLength x
111+ {-# INLINE basicUnsafeSlice #-}
112+ basicUnsafeSlice i_ m_ (FingerprintVector as bs) =
113+ FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs)
114+ {-# INLINE basicUnsafeIndexM #-}
115+ basicUnsafeIndexM (FingerprintVector as bs) i_ = do
116+ a <- G.basicUnsafeIndexM as i_
117+ b <- G.basicUnsafeIndexM bs i_
118+ return (Fingerprint a b)
119+ {-# INLINE basicUnsafeCopy #-}
120+ basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do
121+ G.basicUnsafeCopy as1 as2
122+ G.basicUnsafeCopy bs1 bs2
123+ {-# INLINE elemseq #-}
124+ elemseq _ (Fingerprint a b)
125+ = G.elemseq (undefined :: Unboxed.Vector a) a
126+ . G.elemseq (undefined :: Unboxed.Vector b) b
127+
128+data TypeRepVector f = TypeRepVect
129+ { fingerprints :: Unboxed.Vector Fingerprint
130+ , anys :: V.Vector Any
131+ }
132+
133+fromAny :: Any -> f a
134+fromAny = unsafeCoerce
135+
136+-- | Empty structure.
137+empty :: TypeRepVector f
138+empty = TypeRepVect mempty mempty
139+
140+-- | Inserts the value with its type as a key.
141+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
142+insert = undefined
143+
144+-- | Looks up the value at the type.
145+-- >>> let x = lookup $ insert (11 :: Int) empty
146+-- >>> x :: Maybe Int
147+-- Just 11a Ty
148+-- >>> x :: Maybe ()
149+-- Nothing
150+lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
151+lookup tVect = fromAny . (anys tVect V.!)
152+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
153+
154+-- | Returns the size of the 'TypeRepVect'.
155+size :: TypeRepVector f -> Int
156+size = Unboxed.length . fingerprints
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+
175+-- | Returns the index is found.
176+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
177+binarySearch fp fpVect =
178+ let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
179+ if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
180+ where
181+ binSearchHelp :: Int -> Int -> Int
182+ binSearchHelp l r = if l < r - 1
183+ then (
184+ let m = (l + r) `div` 2 in
185+ if fpVect Unboxed.! m < fp
186+ then binSearchHelp m r
187+ else binSearchHelp l m )
188+ else r