ffi: Don't allow wrapper stub with CApi convention

Fixes #20272

6 files changed, 28 insertions, 4 deletions

diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 1d34129474..9396961cab 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -469,6 +469,7 @@ instance Diagnostic PsMessage where
             [ text "Parse error" <> colon <+> quotes (ppr arr)
             , text "Record constructors in GADTs must use an ordinary, non-linear arrow."
             ]
+    PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."]
 
   diagnosticReason  = \case
     PsUnknownMessage m                            -> diagnosticReason m
@@ -580,6 +581,7 @@ instance Diagnostic PsMessage where
     PsErrInvalidPackageName{}                     -> ErrorWithoutFlag
     PsErrParseRightOpSectionInPat{}               -> ErrorWithoutFlag
     PsErrIllegalGadtRecordMultiplicity{}          -> ErrorWithoutFlag
+    PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag
 
   diagnosticHints  = \case
     PsUnknownMessage m                            -> diagnosticHints m
@@ -737,6 +739,7 @@ instance Diagnostic PsMessage where
     PsErrUnexpectedTypeInDecl{}                   -> noHints
     PsErrInvalidPackageName{}                     -> noHints
     PsErrIllegalGadtRecordMultiplicity{}          -> noHints
+    PsErrInvalidCApiImport {}                     -> noHints
 
 psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc
 psHeaderMessageDiagnostic = \case
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 8f1df7308e..181f793741 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -440,6 +440,8 @@ data PsMessage
    -- | Illegal linear arrow or multiplicity annotation in GADT record syntax
    | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)
 
+   | PsErrInvalidCApiImport
+
 newtype StarIsType = StarIsType Bool
 
 -- | Extra details about a parse error, which helps
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 4eab0c1486..af92355240 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2528,9 +2528,13 @@ mkImport :: Located CCallConv
          -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
 mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
     case unLoc cconv of
-      CCallConv          -> mkCImport
-      CApiConv           -> mkCImport
-      StdCallConv        -> mkCImport
+      CCallConv          -> returnSpec =<< mkCImport
+      CApiConv           -> do
+        imp <- mkCImport
+        if isCWrapperImport imp
+          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
+          else returnSpec imp
+      StdCallConv        -> returnSpec =<< mkCImport
       PrimCallConv       -> mkOtherImport
       JavaScriptCallConv -> mkOtherImport
   where
@@ -2543,7 +2547,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
       case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
         Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $
                              PsErrMalformedEntityString
-        Just importSpec -> returnSpec importSpec
+        Just importSpec -> return importSpec
+
+    isCWrapperImport (CImport _ _ _ CWrapper _) = True
+    isCWrapperImport _ = False
 
     -- currently, all the other import conventions only support a symbol name in
     -- the entity string. If it is missing, we use the function name instead.
diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T
index afe4370273..ce1c10534e 100644
--- a/testsuite/tests/ffi/should_fail/all.T
+++ b/testsuite/tests/ffi/should_fail/all.T
@@ -24,3 +24,5 @@ test('UnsafeReenter',
      [omit_ways(threaded_ways), exit_code(1)],
      compile_and_run,
      ['UnsafeReenterC.c'])
+
+test('capi_wrapper', normal, compile_fail, [''])
diff --git a/testsuite/tests/ffi/should_fail/capi_wrapper.hs b/testsuite/tests/ffi/should_fail/capi_wrapper.hs
new file mode 100644
index 0000000000..eb29e617e8
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/capi_wrapper.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE CApiFFI #-}
+import Foreign
+
+foreign import capi "wrapper"
+  wrapBool :: Bool -> IO (FunPtr Bool)
+
+main = pure ()
diff --git a/testsuite/tests/ffi/should_fail/capi_wrapper.stderr b/testsuite/tests/ffi/should_fail/capi_wrapper.stderr
new file mode 100644
index 0000000000..607e228ddd
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/capi_wrapper.stderr
@@ -0,0 +1,3 @@
+
+capi_wrapper.hs:4:21: error:
+    Wrapper stubs can't be used with CApiFFI.