Simplify reifyTypeable

At least, when we use `TypeLits`. Is there some reason we don't
always?

Author: treeowl

fast/Data/Reflection.hs

@@ -432,7 +432,44 @@ subProxy _ _ = error "Exp.(-): undefined"
 -- * Typeable Reflection
 --------------------------------------------------------------------------------
 
+stablePtrToIntPtr :: StablePtr a -> IntPtr
+stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr
+{-# INLINE stablePtrToIntPtr #-}
+
+intPtrToStablePtr :: IntPtr -> StablePtr a
+intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr
+{-# INLINE intPtrToStablePtr #-}
+
+argument :: (p s -> r) -> Proxy s
+argument _ = Proxy
+
+-- This had to be moved to the top level, due to an apparent bug in
+-- the ghc inliner introduced in ghc 7.0.x
+reflectBefore :: forall (proxy :: * -> *) s b. (Proxy s -> b) -> proxy s -> b
+reflectBefore f = const $! f Proxy
+{-# NOINLINE reflectBefore #-}
+
 
+#if USE_TYPE_LITS
+reifyTypeable :: {- Typeable a => -} a -> (forall (s :: *). (Typeable s, Reifies s a) => Proxy s -> r) -> r
+#  if MIN_VERSION_base(4,4,0)
+reifyTypeable (a :: a) k = unsafeDupablePerformIO $ do
+#  else
+reifyTypeable (a :: a) k = unsafePerformIO $ do
+#  endif
+  p <- newStablePtr a
+  let n = stablePtrToIntPtr p
+  reifyNat (fromIntegral n) (\(_ :: Proxy n) ->
+                  reflectBefore (fmap return k) $
+                    (Proxy :: Proxy (Stable n a)))
+data Stable (n :: Nat) a
+instance KnownNat n => Reifies (Stable n a) a where
+  reflect = r where
+      r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p
+      s = argument r
+      p = intPtrToStablePtr $ fromIntegral $ reflect (Proxy :: Proxy n)
+
+#else
 class Typeable s => B s where
   reflectByte :: proxy s -> IntPtr
 
@@ -492,14 +529,6 @@ stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7
 stable _ _ _ _ _ _ _ _ = Proxy
 {-# INLINE stable #-}
 
-stablePtrToIntPtr :: StablePtr a -> IntPtr
-stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr
-{-# INLINE stablePtrToIntPtr #-}
-
-intPtrToStablePtr :: IntPtr -> StablePtr a
-intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr
-{-# INLINE intPtrToStablePtr #-}
-
 byte0 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b0
 byte0 _ = Proxy
 
@@ -524,9 +553,6 @@ byte6 _ = Proxy
 byte7 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b7
 byte7 _ = Proxy
 
-argument :: (p s -> r) -> Proxy s
-argument _ = Proxy
-
 instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7)
     => Reifies (Stable w0 w1 a) a where
   reflect = r where
@@ -543,12 +569,6 @@ instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1
         (reflectByte (byte7 s) `shiftL` 56)
   {-# NOINLINE reflect #-}
 
--- This had to be moved to the top level, due to an apparent bug in
--- the ghc inliner introduced in ghc 7.0.x
-reflectBefore :: forall (proxy :: * -> *) s b. (Proxy s -> b) -> proxy s -> b
-reflectBefore f = const $! f Proxy
-{-# NOINLINE reflectBefore #-}
-
 -- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'.
 --
 -- This can be necessary to work around the changes to @Data.Typeable@ in GHC HEAD.
@@ -570,6 +590,7 @@ reifyTypeable a k = unsafePerformIO $ do
                 reifyByte (fromIntegral (n `shiftR` 56)) (\s7 ->
                   reflectBefore (fmap return k) $
                     stable s0 s1 s2 s3 s4 s5 s6 s7))))))))
+#endif
 
 
 data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a }