@@ -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