git.iko.soy/typerep-map
on main help sign in
[#22] Add 'hoist' (#26)
d8d3413Dmitrii Kovanikov
internal/Data/TypeRep/CacheMap.hs+28−5
compare with main
unifiedsplit
@@ -4,8 +4,10 @@
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MagicHash #-}
6{-# LANGUAGE MagicHash #-}
7−{-# LANGUAGE TypeInType #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE Rank2Types #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
9
11
10-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}
12-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}
11
13
@@ -18,6 +20,7 @@ module Data.TypeRep.CacheMap
18 , one
20 , one
19 , insert
21 , insert
20 , delete
22 , delete
23+ , hoist
21 , lookup
24 , lookup
22 , member
25 , member
23 , size
26 , size
@@ -66,8 +69,6 @@ toFps TypeRepMap{..} = zipWith Fingerprint
66 (Unboxed.toList fingerprintAs)
69 (Unboxed.toList fingerprintAs)
67 (Unboxed.toList fingerprintBs)
70 (Unboxed.toList fingerprintBs)
68
71
69−fromAny :: Any -> f a
70−fromAny = unsafeCoerce
71
72
72-- | Empty structure.
73-- | Empty structure.
73empty :: TypeRepMap f
74empty :: TypeRepMap f
@@ -83,7 +84,7 @@ insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
83insert x = fromListPairs . addX . toPairList
84insert x = fromListPairs . addX . toPairList
84 where
85 where
85 pairX :: (Fingerprint, Any)
86 pairX :: (Fingerprint, Any)
86− pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
87+ pairX@(fpX, _) = (calcFp x, toAny x)
87
88
88 addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]
89 addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]
89 addX l = pairX : deleteByFst fpX l
90 addX l = pairX : deleteByFst fpX l
@@ -106,6 +107,22 @@ delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeR
106delete = fromListPairs . deleteByFst (typeFp @a) . toPairList
107delete = fromListPairs . deleteByFst (typeFp @a) . toPairList
107{-# INLINE delete #-}
108{-# INLINE delete #-}
108
109
110+{- | Map over elements.
111+
112+>>> let trMap = insert (Identity True) $ one (Identity 'a')
113+>>> lookup @Bool trMap
114+Just (Identity True)
115+>>> lookup @Char trMap
116+Just (Identity 'a')
117+>>> let trMap2 = hoist ((:[]) . runIdentity) trMap
118+>>> lookup @Bool trMap2
119+Just [True]
120+>>> lookup @Char trMap2
121+Just "a"
122+-}
123+hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g
124+hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ V.map (toAny . f . fromAny) ans
125+
109{- | Returns 'True' if there exist value of given type.
126{- | Returns 'True' if there exist value of given type.
110
127
111>>> member @Char $ one (Identity 'a')
128>>> member @Char $ one (Identity 'a')
@@ -166,6 +183,12 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
166-- Internal functions
183-- Internal functions
167----------------------------------------------------------------------------
184----------------------------------------------------------------------------
168
185
186+toAny :: f a -> Any
187+toAny = unsafeCoerce
188+
189+fromAny :: Any -> f a
190+fromAny = unsafeCoerce
191+
169typeFp :: forall a . Typeable a => Fingerprint
192typeFp :: forall a . Typeable a => Fingerprint
170typeFp = typeRepFingerprint $ typeRep $ Proxy @a
193typeFp = typeRepFingerprint $ typeRep $ Proxy @a
171{-# INLINE typeFp #-}
194{-# INLINE typeFp #-}
@@ -204,7 +227,7 @@ fromList = fromListPairs . map (fp &&& an)
204 fp (TF x) = calcFp x
227 fp (TF x) = calcFp x
205
228
206 an :: TF f -> Any
229 an :: TF f -> Any
207− an (TF x) = unsafeCoerce x
230+ an (TF x) = toAny x
208
231
209fromF :: Typeable a => f a -> Proxy a
232fromF :: Typeable a => f a -> Proxy a
210fromF _ = Proxy
233fromF _ = Proxy
src/Data/TypeRep/Map.hs+6−1
@@ -4,11 +4,16 @@ module Data.TypeRep.Map
4 ( -- * Map type
4 ( -- * Map type
5 TypeRepMap (..)
5 TypeRepMap (..)
6
6
7− -- 'TypeRepMap' interface
7+ -- * Construction
8 , empty
8 , empty
9 , one
9 , one
10+
11+ -- * Modification
10 , insert
12 , insert
11 , delete
13 , delete
14+ , hoist
15+
16+ -- * Query
12 , lookup
17 , lookup
13 , member
18 , member
14 , size
19 , size