Simplify reifyTypeable

fast/Data/Reflection.hs

@@ -108,12 +108,16 @@ module Data.Reflection
     ) where
 
 import Control.Applicative
+import Control.Exception
 
 #ifdef MIN_VERSION_template_haskell
 import Control.Monad
 #endif
 
+#if __GLASGOW_HASKELL__ < 800
 import Data.Bits
+import Data.Word
+#endif
 
 #if __GLASGOW_HASKELL__ < 710
 import Data.Foldable
@@ -127,7 +131,6 @@ import Data.Traversable
 #endif
 
 import Data.Typeable
-import Data.Word
 import Foreign.Ptr
 import Foreign.StablePtr
 
@@ -432,7 +435,36 @@ subProxy _ _ = error "Exp.(-): undefined"
 -- * Typeable Reflection
 --------------------------------------------------------------------------------
 
+stablePtrToIntPtr :: StablePtr a -> IntPtr
+stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr
+{-# INLINE stablePtrToIntPtr #-}
+
+intPtrToStablePtr :: IntPtr -> StablePtr a
+intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr
+{-# INLINE intPtrToStablePtr #-}
+
+
+#if __GLASGOW_HASKELL__ >= 800
+-- This implementation doesn't work before 8.0 because KnownNat didn't
+-- imply Typeable until then.
+reifyTypeable :: Typeable a => a -> (forall (s :: *). (Typeable s, Reifies s a) => Proxy s -> r) -> r
+reifyTypeable (a :: a) k = unsafeDupablePerformIO $ do
+  p <- newStablePtr a
+  let n = stablePtrToIntPtr p
+  reifyNat (fromIntegral n) (\(_ :: Proxy n) -> do
+    -- Make sure we don't leak memory if `reflect` isn't otherwise used.
+    _ <- evaluate (reflect :: Proxy (Stable n a) -> a)
+    pure $ 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
+      p = intPtrToStablePtr $ fromIntegral $ reflect (Proxy :: Proxy n)
+  {-# NOINLINE reflect #-}
+
+#else
+-- We are in a world of pain
 class Typeable s => B s where
   reflectByte :: proxy s -> IntPtr
 
@@ -492,14 +524,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
 
@@ -570,6 +594,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 }