@@ -0,0 +1,151 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE MagicHash #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE TypeFamilies #-}
7+
8+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}
9+
10+module Data.TypeRep.CacheMap
11+ ( -- * Map type
12+ TypeRepMap (..)
13+
14+ -- 'TypeRepMap' interface
15+ , empty
16+ , insert
17+ , lookup
18+ , size
19+
20+ -- * Helpful testing functions
21+ , TF (..)
22+ , fromList
23+ ) where
24+
25+import Prelude hiding (lookup)
26+
27+import Control.Arrow ((&&&))
28+import Data.Kind (Type)
29+import Data.Proxy (Proxy (..))
30+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
31+import Data.Word (Word64)
32+import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))
33+import GHC.Exts (inline, sortWith)
34+import GHC.Fingerprint (Fingerprint (..))
35+import GHC.Prim (eqWord#, ltWord#)
36+import GHC.Word (Word64 (..))
37+import Unsafe.Coerce (unsafeCoerce)
38+
39+import qualified Data.Vector as V
40+import qualified Data.Vector.Unboxed as Unboxed
41+
42+data TypeRepMap (f :: k -> Type) = TypeRepMap
43+ { fingerprintAs :: Unboxed.Vector Word64
44+ , fingerprintBs :: Unboxed.Vector Word64
45+ , anys :: V.Vector Any
46+ }
47+
48+fromAny :: Any -> f a
49+fromAny = unsafeCoerce
50+
51+-- | Empty structure.
52+empty :: TypeRepMap f
53+empty = TypeRepMap mempty mempty mempty
54+
55+-- | Inserts the value with its type as a key.
56+insert :: forall a f . Typeable a => a -> TypeRepMap f -> TypeRepMap f
57+insert = undefined
58+
59+-- | Looks up the value at the type.
60+-- >>> let x = lookup $ insert (11 :: Int) empty
61+-- >>> x :: Maybe Int
62+-- Just 11
63+-- >>> x :: Maybe ()
64+-- Nothing
65+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
66+lookup tVect = fromAny . (anys tVect V.!)
67+ <$> cachedBinarySearch (typeRepFingerprint $ typeRep $ Proxy @a)
68+ (fingerprintAs tVect)
69+ (fingerprintBs tVect)
70+{-# INLINE lookup #-}
71+
72+-- | Returns the size of the 'TypeRepMap'.
73+size :: TypeRepMap f -> Int
74+size = Unboxed.length . fingerprintAs
75+
76+-- | Binary searched based on this article
77+-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html
78+-- with modification for our two-vector search case.
79+cachedBinarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
80+cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
81+ where
82+ go :: Int# -> Maybe Int
83+ go i = case i <# len of
84+ 0# -> Nothing
85+ _ -> let !(W64# valA) = Unboxed.unsafeIndex fpAs (I# i) in case a `ltWord#` valA of
86+ 0# -> case a `eqWord#` valA of
87+ 0# -> go (2# *# i +# 2#)
88+ _ -> let !(W64# valB) = Unboxed.unsafeIndex fpBs (I# i) in case b `eqWord#` valB of
89+ 0# -> case b `ltWord#` valB of
90+ 0# -> go (2# *# i +# 2#)
91+ _ -> go (2# *# i +# 1#)
92+ _ -> Just (I# i)
93+ _ -> go (2# *# i +# 1#)
94+
95+ len :: Int#
96+ len = let !(I# l) = Unboxed.length fpAs in l
97+{-# INLINE cachedBinarySearch #-}
98+
99+----------------------------------------------------------------------------
100+-- Functions for testing and benchmarking
101+----------------------------------------------------------------------------
102+
103+data TF f where
104+ TF :: Typeable a => f a -> TF f
105+
106+fromF :: Typeable a => f a -> Proxy a
107+fromF _ = Proxy
108+
109+fromList :: forall f . [TF f] -> TypeRepMap f
110+fromList tfs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
111+ where
112+ (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps
113+ (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst $ map (fp &&& an) tfs
114+
115+ fp :: TF f -> Fingerprint
116+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x
117+
118+ an :: TF f -> Any
119+ an (TF x) = unsafeCoerce x
120+
121+----------------------------------------------------------------------------
122+-- Tree
123+----------------------------------------------------------------------------
124+
125+data Tree a = Leaf | Node a (Tree a) (Tree a)
126+ deriving (Show)
127+
128+fromListToTree :: [a] -> Tree a
129+fromListToTree [] = Leaf
130+fromListToTree xs =
131+ let len = length xs
132+ in case splitAt (len `div` 2) xs of
133+ ([], []) -> Leaf
134+ (ls, []) -> Node (last ls) (fromListToTree $ init ls) Leaf
135+ ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
136+ (ls, r:rs) -> Node r (fromListToTree ls) (fromListToTree rs)
137+
138+breadthFirst :: Tree a -> [a]
139+breadthFirst tree = bf [tree]
140+ where
141+ bf :: [Tree a] -> [a]
142+ bf [] = []
143+ bf xs = mapValue xs ++ bf (concatMap children xs)
144+
145+ mapValue :: [Tree a] -> [a]
146+ mapValue [] = []
147+ mapValue (Leaf : xs) = mapValue xs
148+ mapValue (Node a _ _ : xs) = a : mapValue xs
149+
150+ children Leaf = []
151+ children (Node _ l r) = [l, r]