ffi: Don't allow wrapper stub with CApi convention

Fixes #20272

(cherry picked from commit fb1e0a5da67f075ae4f487e111fcf69d1dfcd42f)

6 files changed, 29 insertions, 4 deletions

diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs
index 6a6ddbfc88..19e1ff4e9f 100644
--- a/compiler/GHC/Parser/Errors.hs
+++ b/compiler/GHC/Parser/Errors.hs
@@ -367,6 +367,9 @@ data PsErrorDesc
    | PsErrLinearFunction
       -- ^ Linear function found but LinearTypes not enabled
 
+   | PsErrInvalidCApiImport
+      -- ^ Invalid CApi import
+
    | PsErrMultiWayIf
       -- ^ Multi-way if-expression found but MultiWayIf not enabled
 
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index bee2e4d7c8..da808927f3 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -584,6 +584,9 @@ pp_err = \case
    PsErrLinearFunction
       -> text "Enable LinearTypes to allow linear functions"
 
+   PsErrInvalidCApiImport {}
+      -> text "Wrapper stubs can't be used with CApiFFI."
+
    PsErrMultiWayIf
       -> text "Multi-way if-expressions need MultiWayIf turned on"
 
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index f3974d7aa2..2283c3689c 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2500,9 +2500,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 $ PsError PsErrInvalidCApiImport [] loc
+          else returnSpec imp
+      StdCallConv        -> returnSpec =<< mkCImport
       PrimCallConv       -> mkOtherImport
       JavaScriptCallConv -> mkOtherImport
   where
@@ -2514,7 +2518,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
       let e = unpackFS entity
       case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
         Nothing         -> addFatalError $ PsError PsErrMalformedEntityString [] loc
-        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.