Ensure Any is not levity-polymorphic in FFI

The previous patch forgot to account for a type such as

  Any @(TYPE (BoxedRep l))

for a quantified levity variable l.

4 files changed, 30 insertions, 13 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index d6ae874d15..76dec32239 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -122,11 +122,12 @@ module GHC.Core.Type (
 
         -- *** Levity and boxity
         typeLevity_maybe,
-        isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind,
+        isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,
         isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,
         isBoxedRuntimeRep,
         isLiftedLevity, isUnliftedLevity,
         isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
+        kindBoxedRepLevity_maybe,
         mightBeLiftedType, mightBeUnliftedType,
         isStateType,
         isAlgType, isDataFamilyAppType,
@@ -664,16 +665,6 @@ kindRep_maybe kind
   | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg
   | otherwise                                           = Nothing
 
--- | Returns True if the kind classifies types which are allocated on
--- the GC'd heap and False otherwise. Note that this returns False for
--- representation-polymorphic kinds, which may be specialized to a kind that
--- classifies AddrRep or even unboxed kinds.
-isBoxedTypeKind :: Kind -> Bool
-isBoxedTypeKind kind
-  = case kindRep_maybe kind of
-      Just rep -> isBoxedRuntimeRep rep
-      Nothing  -> False
-
 -- | This version considers Constraint to be the same as *. Returns True
 -- if the argument is equivalent to Type/Constraint and False otherwise.
 -- See Note [Kind Constraint and kind Type]
@@ -754,6 +745,22 @@ runtimeRepLevity_maybe rep
         -- hence the isPromotedDataCon rr_tc
 runtimeRepLevity_maybe _ = Nothing
 
+-- | Check whether a kind is of the form @TYPE (BoxedRep Lifted)@
+-- or @TYPE (BoxedRep Unlifted)@.
+--
+-- Returns:
+--
+--  - @Just Lifted@ for @TYPE (BoxedRep Lifted)@ and @Type@,
+--  - @Just Unlifted@ for @TYPE (BoxedRep Unlifted)@ and @UnliftedType@,
+--  - @Nothing@ for anything else, e.g. @TYPE IntRep@, @TYPE (BoxedRep l)@, etc.
+kindBoxedRepLevity_maybe :: Type -> Maybe Levity
+kindBoxedRepLevity_maybe ty
+  | Just rep <- kindRep_maybe ty
+  , isBoxedRuntimeRep rep
+  = runtimeRepLevity_maybe rep
+  | otherwise
+  = Nothing
+
 -- | Check whether a type of kind 'RuntimeRep' is lifted.
 --
 -- 'isLiftedRuntimeRep' is:
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 9caf6c9f5b..63ba3e01c5 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -2289,10 +2289,10 @@ isFFILabelTy ty = checkRepTyCon ok ty
 --  - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types,
 --  - @Nothing@ if the type is not @Any@.
 checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
-checkAnyTy  ty
+checkAnyTy ty
   | Just ki <- anyTy_maybe ty
   = Just $
-      if isBoxedTypeKind ki
+      if isJust $ kindBoxedRepLevity_maybe ki
       then IsValid
       -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305.
       else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny)
diff --git a/testsuite/tests/ffi/should_fail/T21305_fail.hs b/testsuite/tests/ffi/should_fail/T21305_fail.hs
index c6f8d6863a..b7746999b8 100644
--- a/testsuite/tests/ffi/should_fail/T21305_fail.hs
+++ b/testsuite/tests/ffi/should_fail/T21305_fail.hs
@@ -4,4 +4,6 @@ module T21305_fail where
 
 import GHC.Exts
 
+foreign import prim "g" g :: forall (l :: Levity). Any @(TYPE (BoxedRep l)) -> Any
+
 foreign import prim "f" f :: Any @(TYPE IntRep) -> Any
diff --git a/testsuite/tests/ffi/should_fail/T21305_fail.stderr b/testsuite/tests/ffi/should_fail/T21305_fail.stderr
index d2ed006df8..fae7053d9f 100644
--- a/testsuite/tests/ffi/should_fail/T21305_fail.stderr
+++ b/testsuite/tests/ffi/should_fail/T21305_fail.stderr
@@ -2,6 +2,14 @@
 T21305_fail.hs:7:1: error:
     • Unacceptable argument type in foreign declaration:
         Expected kind ‘Type’ or ‘UnliftedType’,
+        but ‘Any’ has kind ‘TYPE ('BoxedRep l)’
+    • When checking declaration:
+        foreign import prim safe "g" g
+          :: forall (l :: Levity). Any @(TYPE (BoxedRep l)) -> Any
+
+T21305_fail.hs:9:1: error:
+    • Unacceptable argument type in foreign declaration:
+        Expected kind ‘Type’ or ‘UnliftedType’,
         but ‘Any’ has kind ‘TYPE 'IntRep’
     • When checking declaration:
         foreign import prim safe "f" f :: Any @(TYPE IntRep) -> Any