git.iko.soy/typerep-map
on main help sign in
Move from internal
ff8e4deDmitry Kovanikov
internal/Data/TypeRep/CacheMap.hsdeleted−170
compare with main
unifiedsplit
@@ -1,170 +0,0 @@
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 => f a -> TypeRepMap f -> TypeRepMap f
57−insert x = fromListPairs . addX . toPairList
58− where
59− toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
60− toPairList (TypeRepMap as bs ans) = zip (zipWith Fingerprint
61− (Unboxed.toList as)
62− (Unboxed.toList bs))
63− (V.toList ans)
64−
65− pairX :: (Fingerprint, Any)
66− pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
67−
68− addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]
69− addX l = pairX : filter ((/= fpX) . fst) l
70−{-# INLINE insert #-}
71−
72−-- | Looks up the value at the type.
73−-- >>> let x = lookup $ insert (11 :: Int) empty
74−-- >>> x :: Maybe Int
75−-- Just 11
76−-- >>> x :: Maybe ()
77−-- Nothing
78−lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
79−lookup tVect = fromAny . (anys tVect V.!)
80− <$> cachedBinarySearch (typeRepFingerprint $ typeRep $ Proxy @a)
81− (fingerprintAs tVect)
82− (fingerprintBs tVect)
83−{-# INLINE lookup #-}
84−
85−-- | Returns the size of the 'TypeRepMap'.
86−size :: TypeRepMap f -> Int
87−size = Unboxed.length . fingerprintAs
88−
89−-- | Binary searched based on this article
90−-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html
91−-- with modification for our two-vector search case.
92−cachedBinarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
93−cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
94− where
95− go :: Int# -> Maybe Int
96− go i = case i <# len of
97− 0# -> Nothing
98− _ -> let !(W64# valA) = Unboxed.unsafeIndex fpAs (I# i) in case a `ltWord#` valA of
99− 0# -> case a `eqWord#` valA of
100− 0# -> go (2# *# i +# 2#)
101− _ -> let !(W64# valB) = Unboxed.unsafeIndex fpBs (I# i) in case b `eqWord#` valB of
102− 0# -> case b `ltWord#` valB of
103− 0# -> go (2# *# i +# 2#)
104− _ -> go (2# *# i +# 1#)
105− _ -> Just (I# i)
106− _ -> go (2# *# i +# 1#)
107−
108− len :: Int#
109− len = let !(I# l) = Unboxed.length fpAs in l
110−{-# INLINE cachedBinarySearch #-}
111−
112−----------------------------------------------------------------------------
113−-- Functions for testing and benchmarking
114−----------------------------------------------------------------------------
115−
116−data TF f where
117− TF :: Typeable a => f a -> TF f
118−
119−fromF :: Typeable a => f a -> Proxy a
120−fromF _ = Proxy
121−
122−calcFp :: Typeable a => f a -> Fingerprint
123−calcFp = typeRepFingerprint . typeRep . fromF
124−
125−fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f
126−fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
127− where
128− (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
129− (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst kvs
130−
131−fromList :: forall f . [TF f] -> TypeRepMap f
132−fromList = fromListPairs . map (fp &&& an)
133− where
134− fp :: TF f -> Fingerprint
135− fp (TF x) = calcFp x
136−
137− an :: TF f -> Any
138− an (TF x) = unsafeCoerce x
139−
140−----------------------------------------------------------------------------
141−-- Tree
142−----------------------------------------------------------------------------
143−
144−data Tree a = Leaf | Node a (Tree a) (Tree a)
145− deriving (Show)
146−
147−fromListToTree :: [a] -> Tree a
148−fromListToTree [] = Leaf
149−fromListToTree xs =
150− let len = length xs
151− in case splitAt (len `div` 2) xs of
152− ([], []) -> Leaf
153− (ls, []) -> Node (last ls) (fromListToTree $ init ls) Leaf
154− ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
155− (ls, r:rs) -> Node r (fromListToTree ls) (fromListToTree rs)
156−
157−breadthFirst :: Tree a -> [a]
158−breadthFirst tree = bf [tree]
159− where
160− bf :: [Tree a] -> [a]
161− bf [] = []
162− bf xs = mapValue xs ++ bf (concatMap children xs)
163−
164− mapValue :: [Tree a] -> [a]
165− mapValue [] = []
166− mapValue (Leaf : xs) = mapValue xs
167− mapValue (Node a _ _ : xs) = a : mapValue xs
168−
169− children Leaf = []
170− children (Node _ l r) = [l, r]
src/Data/TypeRep/CMap.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE KindSignatures #-}
2+{-# LANGUAGE PolyKinds #-}
3+
4+module Data.TypeRep.CMap
5+ ( TypeRepMap (..)
6+ , empty
7+ , insert
8+ , keys
9+ , lookup
10+ , size
11+ ) where
12+
13+import Prelude hiding (lookup)
14+
15+import Data.Proxy (Proxy (..))
16+import Data.Typeable (TypeRep, Typeable, typeRep)
17+import GHC.Base (Any)
18+import Unsafe.Coerce (unsafeCoerce)
19+
20+import qualified Data.Map.Lazy as LMap
21+
22+-- | Map-like data structure with types served as the keys.
23+newtype TypeRepMap (f :: k -> *) = TypeRepMap
24+ { unMap :: LMap.Map TypeRep Any
25+ }
26+
27+-- | Empty structure.
28+empty :: TypeRepMap f
29+empty = TypeRepMap mempty
30+
31+-- | Inserts the value with its type as a key.
32+insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
33+insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap
34+
35+-- | Looks up the value at the type.
36+-- >>> let x = lookup $ insert (11 :: Int) empty
37+-- >>> x :: Maybe Int
38+-- Just 11
39+-- >>> x :: Maybe ()
40+-- Nothing
41+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
42+lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap
43+
44+size :: TypeRepMap f -> Int
45+size = LMap.size . unMap
46+
47+keys :: TypeRepMap f -> [TypeRep]
48+keys = LMap.keys . unMap
src/Data/TypeRep/Map.hs+153−1
@@ -1,3 +1,12 @@
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+
1module Data.TypeRep.Map
10module Data.TypeRep.Map
2 ( -- * Map type
11 ( -- * Map type
3 TypeRepMap (..)
12 TypeRepMap (..)
@@ -15,4 +24,147 @@ module Data.TypeRep.Map
15
24
16import Prelude hiding (lookup)
25import Prelude hiding (lookup)
17
26
18−import Data.TypeRep.CacheMap
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 => f a -> TypeRepMap f -> TypeRepMap f
57+insert x = fromListPairs . addX . toPairList
58+ where
59+ toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
60+ toPairList (TypeRepMap as bs ans) = zip (zipWith Fingerprint
61+ (Unboxed.toList as)
62+ (Unboxed.toList bs))
63+ (V.toList ans)
64+
65+ pairX :: (Fingerprint, Any)
66+ pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
67+
68+ addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]
69+ addX l = pairX : filter ((/= fpX) . fst) l
70+{-# INLINE insert #-}
71+
72+-- | Looks up the value at the type.
73+-- >>> let x = lookup $ insert (11 :: Int) empty
74+-- >>> x :: Maybe Int
75+-- Just 11
76+-- >>> x :: Maybe ()
77+-- Nothing
78+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
79+lookup tVect = fromAny . (anys tVect V.!)
80+ <$> cachedBinarySearch (typeRepFingerprint $ typeRep $ Proxy @a)
81+ (fingerprintAs tVect)
82+ (fingerprintBs tVect)
83+-- {-# INLINE lookup #-}
84+
85+-- | Returns the size of the 'TypeRepMap'.
86+size :: TypeRepMap f -> Int
87+size = Unboxed.length . fingerprintAs
88+
89+-- | Binary searched based on this article
90+-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html
91+-- with modification for our two-vector search case.
92+cachedBinarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
93+cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
94+ where
95+ go :: Int# -> Maybe Int
96+ go i = case i <# len of
97+ 0# -> Nothing
98+ _ -> let !(W64# valA) = Unboxed.unsafeIndex fpAs (I# i) in case a `ltWord#` valA of
99+ 0# -> case a `eqWord#` valA of
100+ 0# -> go (2# *# i +# 2#)
101+ _ -> let !(W64# valB) = Unboxed.unsafeIndex fpBs (I# i) in case b `eqWord#` valB of
102+ 0# -> case b `ltWord#` valB of
103+ 0# -> go (2# *# i +# 2#)
104+ _ -> go (2# *# i +# 1#)
105+ _ -> Just (I# i)
106+ _ -> go (2# *# i +# 1#)
107+
108+ len :: Int#
109+ len = let !(I# l) = Unboxed.length fpAs in l
110+-- {-# INLINE cachedBinarySearch #-}
111+
112+----------------------------------------------------------------------------
113+-- Functions for testing and benchmarking
114+----------------------------------------------------------------------------
115+
116+data TF f where
117+ TF :: Typeable a => f a -> TF f
118+
119+fromF :: Typeable a => f a -> Proxy a
120+fromF _ = Proxy
121+
122+calcFp :: Typeable a => f a -> Fingerprint
123+calcFp = typeRepFingerprint . typeRep . fromF
124+
125+fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f
126+fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
127+ where
128+ (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
129+ (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst kvs
130+
131+fromList :: forall f . [TF f] -> TypeRepMap f
132+fromList = fromListPairs . map (fp &&& an)
133+ where
134+ fp :: TF f -> Fingerprint
135+ fp (TF x) = calcFp x
136+
137+ an :: TF f -> Any
138+ an (TF x) = unsafeCoerce x
139+
140+----------------------------------------------------------------------------
141+-- Tree
142+----------------------------------------------------------------------------
143+
144+data Tree a = Leaf | Node a (Tree a) (Tree a)
145+ deriving (Show)
146+
147+fromListToTree :: [a] -> Tree a
148+fromListToTree [] = Leaf
149+fromListToTree xs =
150+ let len = length xs
151+ in case splitAt (len `div` 2) xs of
152+ ([], []) -> Leaf
153+ (ls, []) -> Node (last ls) (fromListToTree $ init ls) Leaf
154+ ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
155+ (ls, r:rs) -> Node r (fromListToTree ls) (fromListToTree rs)
156+
157+breadthFirst :: Tree a -> [a]
158+breadthFirst tree = bf [tree]
159+ where
160+ bf :: [Tree a] -> [a]
161+ bf [] = []
162+ bf xs = mapValue xs ++ bf (concatMap children xs)
163+
164+ mapValue :: [Tree a] -> [a]
165+ mapValue [] = []
166+ mapValue (Leaf : xs) = mapValue xs
167+ mapValue (Node a _ _ : xs) = a : mapValue xs
168+
169+ children Leaf = []
170+ children (Node _ l r) = [l, r]
src/Data/TypeRep/OptimalVector.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE MagicHash #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE TypeFamilies #-}
7+
8+module Data.TypeRep.OptimalVector
9+ ( -- * Map type
10+ TypeRepMap (..)
11+
12+ -- 'TypeRepMap' interface
13+ , empty
14+ , insert
15+ , lookup
16+ , size
17+
18+ -- * Helpful testing functions
19+ , TF (..)
20+ , fromList
21+ ) where
22+
23+import Prelude hiding (lookup)
24+
25+import Control.Arrow ((&&&))
26+import Data.Kind (Type)
27+import Data.Proxy (Proxy (..))
28+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
29+import Data.Word (Word64)
30+import GHC.Base (Any, Int (..), Int#, uncheckedIShiftRA#, (+#), (-#), (<#))
31+import GHC.Exts (inline, sortWith)
32+import GHC.Fingerprint (Fingerprint (..))
33+import Unsafe.Coerce (unsafeCoerce)
34+
35+import qualified Data.Vector as V
36+import qualified Data.Vector.Unboxed as Unboxed
37+
38+data TypeRepMap (f :: k -> Type) = TypeRepMap
39+ { fingerprintAs :: Unboxed.Vector Word64
40+ , fingerprintBs :: Unboxed.Vector Word64
41+ , anys :: V.Vector Any
42+ }
43+
44+fromAny :: Any -> f a
45+fromAny = unsafeCoerce
46+
47+-- | Empty structure.
48+empty :: TypeRepMap f
49+empty = TypeRepMap mempty mempty mempty
50+
51+-- | Inserts the value with its type as a key.
52+insert :: forall a f . Typeable a => a -> TypeRepMap f -> TypeRepMap f
53+insert = undefined
54+
55+-- | Looks up the value at the type.
56+-- >>> let x = lookup $ insert (11 :: Int) empty
57+-- >>> x :: Maybe Int
58+-- Just 11
59+-- >>> x :: Maybe ()
60+-- Nothing
61+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)
62+lookup tVect = fromAny . (anys tVect V.!)
63+ <$> binarySearch (typeRepFingerprint $ typeRep $ Proxy @a)
64+ (fingerprintAs tVect)
65+ (fingerprintBs tVect)
66+
67+-- | Returns the size of the 'TypeRepMap'.
68+size :: TypeRepMap f -> Int
69+size = Unboxed.length . fingerprintAs
70+
71+-- | Returns the index is found.
72+binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
73+binarySearch (Fingerprint a b) fpAs fpBs =
74+ let
75+ !(I# len) = Unboxed.length fpAs
76+ checkfpBs :: Int# -> Maybe Int
77+ checkfpBs i =
78+ case i <# len of
79+ 0# -> Nothing
80+ _ ->
81+ if a /= Unboxed.unsafeIndex fpAs (I# i)
82+ then Nothing
83+ else if b == Unboxed.unsafeIndex fpBs (I# i)
84+ then Just (I# i)
85+ else checkfpBs (i +# 1#)
86+ in
87+ inline (checkfpBs (binSearchHelp (-1#) len))
88+ where
89+ binSearchHelp :: Int# -> Int# -> Int#
90+ binSearchHelp l r = case l <# (r -# 1#) of
91+ 0# -> r
92+ _ ->
93+ let m = uncheckedIShiftRA# (l +# r) 1# in
94+ if Unboxed.unsafeIndex fpAs (I# m) < a
95+ then binSearchHelp m r
96+ else binSearchHelp l m
97+
98+----------------------------------------------------------------------------
99+-- Functions for testing and benchmarking
100+----------------------------------------------------------------------------
101+
102+data TF f where
103+ TF :: Typeable a => f a -> TF f
104+
105+fromF :: Typeable a => f a -> Proxy a
106+fromF _ = Proxy
107+
108+fromList :: forall f . [TF f] -> TypeRepMap f
109+fromList tfs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
110+ where
111+ (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps
112+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs
113+
114+ fp :: TF f -> Fingerprint
115+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x
116+
117+ an :: TF f -> Any
118+ an (TF x) = unsafeCoerce x
typerep-map.cabal+6−3
@@ -19,9 +19,12 @@ tested-with: GHC == 8.0.2
19library
19library
20 hs-source-dirs: src
20 hs-source-dirs: src
21 exposed-modules: Data.TypeRep.Map
21 exposed-modules: Data.TypeRep.Map
22+-- Data.TypeRep.CacheMap
22 ghc-options: -Wall
23 ghc-options: -Wall
23 build-depends: base
24 build-depends: base
24 , typerep-map-internal
25 , typerep-map-internal
26+ , ghc-prim
27+ , vector
25 default-extensions: OverloadedStrings
28 default-extensions: OverloadedStrings
26 RecordWildCards
29 RecordWildCards
27 ScopedTypeVariables
30 ScopedTypeVariables
@@ -29,11 +32,11 @@ library
29 default-language: Haskell2010
32 default-language: Haskell2010
30
33
31library typerep-map-internal
34library typerep-map-internal
32− hs-source-dirs: internal
35+ hs-source-dirs: src
33 exposed-modules: Data.TypeRep.CMap
36 exposed-modules: Data.TypeRep.CMap
34− Data.TypeRep.CacheMap
37+-- Data.TypeRep.CacheMap
35 Data.TypeRep.OptimalVector
38 Data.TypeRep.OptimalVector
36− Data.TypeRep.Vector
39+-- Data.TypeRep.Vector
37 ghc-options: -Wall
40 ghc-options: -Wall
38 build-depends: base
41 build-depends: base
39 , containers
42 , containers