@@ -4,8 +4,10 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE KindSignatures #-}
66{-# LANGUAGE MagicHash #-}
7−{-# LANGUAGE TypeInType #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE Rank2Types #-}
89{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
911
1012-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}
1113
@@ -18,6 +20,7 @@ module Data.TypeRep.CacheMap
1820 , one
1921 , insert
2022 , delete
23+ , hoist
2124 , lookup
2225 , member
2326 , size
@@ -66,8 +69,6 @@ toFps TypeRepMap{..} = zipWith Fingerprint
6669 (Unboxed.toList fingerprintAs)
6770 (Unboxed.toList fingerprintBs)
6871
69−fromAny :: Any -> f a
70−fromAny = unsafeCoerce
7172
7273-- | Empty structure.
7374empty :: TypeRepMap f
@@ -83,7 +84,7 @@ insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
8384insert x = fromListPairs . addX . toPairList
8485 where
8586 pairX :: (Fingerprint, Any)
86− pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
87+ pairX@(fpX, _) = (calcFp x, toAny x)
8788
8889 addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]
8990 addX l = pairX : deleteByFst fpX l
@@ -106,6 +107,22 @@ delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeR
106107delete = fromListPairs . deleteByFst (typeFp @a) . toPairList
107108{-# INLINE delete #-}
108109
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+
109126{- | Returns 'True' if there exist value of given type.
110127
111128>>> member @Char $ one (Identity 'a')
@@ -166,6 +183,12 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
166183-- Internal functions
167184----------------------------------------------------------------------------
168185
186+toAny :: f a -> Any
187+toAny = unsafeCoerce
188+
189+fromAny :: Any -> f a
190+fromAny = unsafeCoerce
191+
169192typeFp :: forall a . Typeable a => Fingerprint
170193typeFp = typeRepFingerprint $ typeRep $ Proxy @a
171194{-# INLINE typeFp #-}
@@ -204,7 +227,7 @@ fromList = fromListPairs . map (fp &&& an)
204227 fp (TF x) = calcFp x
205228
206229 an :: TF f -> Any
207− an (TF x) = unsafeCoerce x
230+ an (TF x) = toAny x
208231
209232fromF :: Typeable a => f a -> Proxy a
210233fromF _ = Proxy