git.iko.soy/typerep-map
on e4fe422 help sign in
typerep-map/src/Data/TypeRep/Vector.hs
180 lines 6.4 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
3{-# LANGUAGE ExplicitForAll #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
11module Data.TypeRep.Vector
12 ( TypeRepVector (..)
13 , empty
14 , insert
15 , lookup
16 , size
17 ) where
19import Prelude hiding (lookup)
21import Data.Proxy (Proxy (..))
22import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
23import Data.Word (Word64)
24import GHC.Base (Any)
25import GHC.Fingerprint (Fingerprint (..))
26import Unsafe.Coerce (unsafeCoerce)
28import qualified Data.Vector as V
29import qualified Data.Vector.Generic as G
30import qualified Data.Vector.Generic.Mutable as M
31import qualified Data.Vector.Unboxed as Unboxed
33data instance Unboxed.MVector s Fingerprint = MFingerprintVector !Int (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
34data instance Unboxed.Vector Fingerprint = FingerprintVector !Int (Unboxed.Vector Word64) (Unboxed.Vector Word64)
36instance Unboxed.Unbox Fingerprint
38instance 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'
102instance 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
137data TypeRepVector f = TypeRepVect
138 { fingerprints :: Unboxed.Vector Fingerprint
139 , anys :: V.Vector Any
140 }
142fromAny :: Any -> f a
143fromAny = unsafeCoerce
145-- | Empty structure.
146empty :: TypeRepVector f
147empty = TypeRepVect mempty mempty
149-- | Inserts the value with its type as a key.
150insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
151insert = undefined
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
159lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
160lookup tVect = fromAny . (anys tVect V.!)
161 <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
163-- | Returns the size of the 'TypeRepVect'.
164size :: TypeRepVector f -> Int
165size = Unboxed.length . fingerprints
167-- | Returns the index is found.
168binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
169binarySearch 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