@@ -0,0 +1,77 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+
7+
8+module Data.TypeRep.Vector
9+ ( TypeRepVector (..)
10+ , empty
11+ , insert
12+ , lookup
13+ , size
14+ ) where
15+
16+import Prelude hiding (lookup)
17+
18+import Data.Proxy (Proxy (..))
19+import Data.Typeable (TypeRep, Typeable, typeRep, typeRepFingerprint)
20+import Data.Word (Word64)
21+import GHC.Base (Any)
22+import GHC.Fingerprint (Fingerprint (..))
23+import Unsafe.Coerce (unsafeCoerce)
24+
25+import qualified Data.Vector as V
26+import qualified Data.Vector.Unboxed as Unboxed
27+
28+type FingerprintPair = (Word64, Word64)
29+
30+data TypeRepVector f = TypeRepVect
31+ { fingerprints :: Unboxed.Vector FingerprintPair
32+ , anys :: V.Vector Any
33+ }
34+
35+fromFingerprint :: Fingerprint -> FingerprintPair
36+fromFingerprint (Fingerprint x y) = (x, y)
37+
38+typeRepToPair :: TypeRep -> FingerprintPair
39+typeRepToPair = fromFingerprint . typeRepFingerprint
40+
41+-- | Empty structure.
42+empty :: TypeRepVector f
43+empty = TypeRepVect mempty mempty
44+
45+-- | Inserts the value with its type as a key.
46+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
47+insert = undefined
48+
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
55+lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
56+lookup tVect = case binarySearch (typeRepToPair (typeRep (Proxy :: Proxy a))) (fingerprints tVect) of
57+ Just ind -> Just $ unsafeCoerce $ (anys tVect) V.! ind
58+ Nothing -> Nothing
59+
60+-- | Returns the size of the 'TypeRepVect'.
61+size :: TypeRepVector f -> Int
62+size = Unboxed.length . fingerprints
63+
64+-- | Returns the index is found.
65+binarySearch :: FingerprintPair -> Unboxed.Vector FingerprintPair -> Maybe Int
66+binarySearch 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