git.iko.soy/typerep-map
on 39b92b4 help sign in
typerep-map/src/Data/TypeRep/Vector.hs
188 lines 6.6 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
3{-# LANGUAGE ExplicitForAll #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
13module Data.TypeRep.Vector
14 ( TypeRepVector (..)
15 , TF (..)
16 , empty
17 , insert
18 , lookup
19 , size
20 , fromList
21 ) where
23import Prelude hiding (lookup)
25import Control.Arrow ((&&&))
26import Data.Proxy (Proxy (..))
27import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
28import Data.Word (Word64)
29import GHC.Base (Any)
30import GHC.Exts (sortWith)
31import GHC.Fingerprint (Fingerprint (..))
32import Unsafe.Coerce (unsafeCoerce)
34import qualified Data.Vector as V
35import qualified Data.Vector.Generic as G
36import qualified Data.Vector.Generic.Mutable as M
37import qualified Data.Vector.Unboxed as Unboxed
39data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
40data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)
42instance Unboxed.Unbox Fingerprint
44instance 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'
98instance 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
128data TypeRepVector f = TypeRepVect
129 { fingerprints :: Unboxed.Vector Fingerprint
130 , anys :: V.Vector Any
131 }
133fromAny :: Any -> f a
134fromAny = unsafeCoerce
136-- | Empty structure.
137empty :: TypeRepVector f
138empty = TypeRepVect mempty mempty
140-- | Inserts the value with its type as a key.
141insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
142insert = undefined
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
150lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
151lookup tVect = fromAny . (anys tVect V.!)
152 <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
154-- | Returns the size of the 'TypeRepVect'.
155size :: TypeRepVector f -> Int
156size = Unboxed.length . fingerprints
158data TF f where
159 TF :: Typeable a => f a -> TF f
161fromF :: Typeable a => f a -> Proxy a
162fromF _ = Proxy
164fromList :: forall f . [TF f] -> TypeRepVector f
165fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)
166 where
167 (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs
169 fp :: TF f -> Fingerprint
170 fp (TF x) = typeRepFingerprint $ typeRep $ fromF x
172 an :: TF f -> Any
173 an (TF x) = unsafeCoerce x
175-- | Returns the index is found.
176binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
177binarySearch 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