git.iko.soy/typerep-map
on 4e43896 help sign in
typerep-map/src/Data/TypeRep/Vector.hs
77 lines 2.3 kB history raw
1{-# LANGUAGE ExplicitForAll #-}
2{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeFamilies #-}
8module Data.TypeRep.Vector
9 ( TypeRepVector (..)
10 , empty
11 , insert
12 , lookup
13 , size
14 ) where
16import Prelude hiding (lookup)
18import Data.Proxy (Proxy (..))
19import Data.Typeable (TypeRep, Typeable, typeRep, typeRepFingerprint)
20import Data.Word (Word64)
21import GHC.Base (Any)
22import GHC.Fingerprint (Fingerprint (..))
23import Unsafe.Coerce (unsafeCoerce)
25import qualified Data.Vector as V
26import qualified Data.Vector.Unboxed as Unboxed
28type FingerprintPair = (Word64, Word64)
30data TypeRepVector f = TypeRepVect
31 { fingerprints :: Unboxed.Vector FingerprintPair
32 , anys :: V.Vector Any
33 }
35fromFingerprint :: Fingerprint -> FingerprintPair
36fromFingerprint (Fingerprint x y) = (x, y)
38typeRepToPair :: TypeRep -> FingerprintPair
39typeRepToPair = fromFingerprint . typeRepFingerprint
41-- | Empty structure.
42empty :: TypeRepVector f
43empty = TypeRepVect mempty mempty
45-- | Inserts the value with its type as a key.
46insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
47insert = undefined
49-- | Looks up the value at the type.
50-- >>> let x = lookup $ insert (11 :: Int) empty
51-- >>> x :: Maybe Int
52-- Just 11
53-- >>> x :: Maybe ()
54-- Nothing
55lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
56lookup tVect = case binarySearch (typeRepToPair (typeRep (Proxy :: Proxy a))) (fingerprints tVect) of
57 Just ind -> Just $ unsafeCoerce $ (anys tVect) V.! ind
58 Nothing -> Nothing
60-- | Returns the size of the 'TypeRepVect'.
61size :: TypeRepVector f -> Int
62size = Unboxed.length . fingerprints
64-- | Returns the index is found.
65binarySearch :: FingerprintPair -> Unboxed.Vector FingerprintPair -> Maybe Int
66binarySearch fp fpVect =
67 let ind = binSearchHelp (-1) (Unboxed.length fpVect) in
68 if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
69 where
70 binSearchHelp :: Int -> Int -> Int
71 binSearchHelp l r = if l < r - 1
72 then (
73 let m = (l + r) `div` 2 in
74 if fpVect Unboxed.! m < fp
75 then binSearchHelp m r
76 else binSearchHelp l m )
77 else r