Add a Typeable constraint to fromStaticPtr, addressing #19729

4 files changed, 17 insertions, 7 deletions

diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 083c7e68a2..b768df9e48 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -431,11 +431,8 @@ tcExpr (HsStatic fvs expr) res_ty
         ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
 
         -- Require the type of the argument to be Typeable.
-        -- The evidence is not used, but asking the constraint ensures that
-        -- the current implementation is as restrictive as future versions
-        -- of the StaticPointers extension.
         ; typeableClass <- tcLookupClass typeableClassName
-        ; _ <- emitWantedEvVar StaticOrigin $
+        ; typeable_ev <- emitWantedEvVar StaticOrigin $
                   mkTyConApp (classTyCon typeableClass)
                              [liftedTypeKind, expr_ty]
 
@@ -446,7 +443,7 @@ tcExpr (HsStatic fvs expr) res_ty
         -- Wrap the static form with the 'fromStaticPtr' call.
         ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
                                              [p_ty]
-        ; let wrap = mkWpTyApps [expr_ty]
+        ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]
         ; loc <- getSrcSpanM
         ; return $ mkHsWrapCo co $ HsApp noComments
                             (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 655e672a1b..31c0fc3c46 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -61,7 +61,7 @@ Version 9.4.1
 
 - Added ``GHC.Exts.sameArray#``, ``GHC.Exts.sameSmallArray#``,
   ``GHC.Exts.sameByteArray#`` and ``GHC.Exts.sameArrayArray#``: ::
- 
+
         sameArray# :: Array# a -> Array# a -> Int#
         sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
         sameByteArray# :: ByteArray# -> ByteArray# -> Int#
@@ -74,3 +74,8 @@ Version 9.4.1
   for computing the ``Type`` of an ``HsExpr GhcTc`` in a pure fashion.
   The ``hsLitType`` and ``hsPatType`` functions that previously lived in
   ``GHC.Tc.Utils.Zonk`` have been moved to this module.
+- A `Typeable` constraint has been added to `fromStaticPtr` in the
+  class `GHC.StaticPtr.IsStatic`. GHC automatically wraps each use of
+  the `static` keyword with `fromStaticPtr`. Because `static` requires
+  its argument to be an instance of `Typeable`, `fromStaticPtr` can
+  safely carry this constraint as well.
diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
index f478bad8cd..9a1e1232bb 100644
--- a/libraries/base/GHC/StaticPtr.hs
+++ b/libraries/base/GHC/StaticPtr.hs
@@ -48,6 +48,7 @@ module GHC.StaticPtr
   , IsStatic(..)
   ) where
 
+import Data.Typeable       (Typeable)
 import Foreign.C.Types     (CInt(..))
 import Foreign.Marshal     (allocaArray, peekArray, withArray)
 import GHC.Ptr             (Ptr(..), nullPtr)
@@ -97,8 +98,13 @@ unsafeLookupStaticPtr (Fingerprint w1 w2) = do
 foreign import ccall unsafe hs_spt_lookup :: Ptr Word64 -> IO (Ptr a)
 
 -- | A class for things buildable from static pointers.
+--
+-- GHC wraps each use of the 'static' keyword with
+-- 'fromStaticPtr'. Because the 'static' keyword requires its argument
+-- to be an instance of 'Typeable', 'fromStaticPtr' carries a
+-- 'Typeable' constraint as well.
 class IsStatic p where
-    fromStaticPtr :: StaticPtr a -> p a
+    fromStaticPtr :: Typeable a => StaticPtr a -> p a
 
 -- | @since 4.9.0.0
 instance IsStatic StaticPtr where
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index edf876cb26..7c67e937ba 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -15,6 +15,8 @@
 
 ## 4.16.0.0 *TBA*
 
+  * Add a `Typeable` constraint to `fromStaticPtr` in the class `GHC.StaticPtr.IsStatic`.
+
   * Make it possible to promote `Natural`s and remove the separate `Nat` kind.
     For backwards compatibility, `Nat` is now a type synonym for `Natural`.
     As a consequence, one must enable `TypeSynonymInstances`