CApiFFI: add ConstPtr for encoding const-qualified pointer return types

Previously, when using `capi` calling convention in foreign declarations,
code generator failed to handle const-cualified pointer return types.
This resulted in CC toolchain throwing `-Wincompatible-pointer-types-discards-qualifiers`
warning.

`Foreign.C.Types.ConstPtr` newtype was introduced to handle these cases -
special treatment was put in place to generate appropritetly qualified C
wrapper that no longer triggers the above mentioned warning.

Fixes #22043.

(cherry picked from commit b3a3534b6f75b34dc4db76e904e071485da6d5cc)

13 files changed, 118 insertions, 8 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 1d6ca74130..72f746d15c 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -350,7 +350,7 @@ basicKnownKeyNames
         zipName, foldrName, buildName, augmentName, appendName,
 
         -- FFI primitive types that are not wired-in.
-        stablePtrTyConName, ptrTyConName, funPtrTyConName,
+        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,
         int8TyConName, int16TyConName, int32TyConName, int64TyConName,
         word8TyConName, word16TyConName, word32TyConName, word64TyConName,
 
@@ -557,7 +557,7 @@ gHC_PRIM, gHC_PRIM_PANIC,
     aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,
     cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
     gHC_TYPENATS, gHC_TYPENATS_INTERNAL,
-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
+    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")
@@ -626,6 +626,7 @@ gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")
 dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")
 dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")
 uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")
+fOREIGN_C_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr")
 
 gHC_SRCLOC :: Module
 gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -1664,6 +1665,10 @@ fingerprintDataConName :: Name
 fingerprintDataConName =
     dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
 
+constPtrConName :: Name
+constPtrConName =
+    tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1865,7 +1870,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
     eqReprPrimTyConKey, eqPhantPrimTyConKey,
     compactPrimTyConKey, stackSnapshotPrimTyConKey,
-    promptTagPrimTyConKey :: Unique
+    promptTagPrimTyConKey, constPtrTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -2076,6 +2081,7 @@ typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413
 typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414
 typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415
 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416
+constPtrTyConKey = mkPreludeTyConUnique 417
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
index 160e9acc97..b937c00df7 100644
--- a/compiler/GHC/HsToCore/Foreign/C.hs
+++ b/compiler/GHC/HsToCore/Foreign/C.hs
@@ -246,10 +246,18 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
         -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
 dsFCall fn_id co fcall mDeclHeader = do
     let
-        ty                   = coercionLKind co
+        (ty,ty1)             = (coercionLKind co, coercionRKind co)
         (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
         (arg_tys, io_res_ty) = tcSplitFunTys rho
 
+    let constQual -- provide 'const' qualifier (#22043)
+          | (_, res_ty1) <- tcSplitFunTys ty1
+          , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1)
+          , Just (ptr, _) <- splitTyConApp_maybe newty
+          , tyConName ptr == constPtrConName
+          = text "const"
+          | otherwise = empty
+
     args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 
@@ -277,7 +285,7 @@ dsFCall fn_id co fcall mDeclHeader = do
                       includes = vcat [ text "#include \"" <> ftext h
                                         <> text "\""
                                       | Header _ h <- nub headers ]
-                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                       cRet
                        | isVoidRes =                   cCall
                        | otherwise = text "return" <+> cCall
diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst
index 82b3e1e784..1d0eb3baba 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -164,6 +164,9 @@ Runtime system
 ``ghc`` library
 ~~~~~~~~~~~~~~~
 
+- Add `Foreign.C.Types.ConstPtr` was added to encode ``const``-qualified pointer return
+  types in foreign declarations when using ``CApiFFI`` extension.
+
 ``ghc-heap`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst
index b490ac662d..37d96a0a68 100644
--- a/docs/users_guide/exts/ffi.rst
+++ b/docs/users_guide/exts/ffi.rst
@@ -437,6 +437,18 @@ specified. The syntax looks like: ::
     data    {-# CTYPE "unistd.h" "useconds_t" #-} T = ...
     newtype {-# CTYPE            "useconds_t" #-} T = ...
 
+In case foreign declarations contain ``const``-qualified pointer return
+type, ``ConstPtr`` from :base-ref:`Foreign.C.ConstPtr` may be used to
+encode this, e.g. ::
+
+    foreign import capi "header.h f" f :: CInt -> ConstPtr CInt
+
+which corresponds to
+
+.. code-block:: c
+
+    const *int f(int);
+
 ``hs_thread_done()``
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index b6102d4cf3..1a081484a9 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -140,6 +140,7 @@ import Data.Word             -- So we can give Data instance for Word8, ...
 import GHC.Real              -- So we can give Data instance for Ratio
 --import GHC.IOBase            -- So we can give Data instance for IO, Handle
 import GHC.Ptr               -- So we can give Data instance for Ptr
+import Foreign.C.ConstPtr    -- So we can give Data instance for ConstPtr
 import GHC.ForeignPtr        -- So we can give Data instance for ForeignPtr
 import Foreign.Ptr (IntPtr(..), WordPtr(..))
                              -- So we can give Data instance for IntPtr and WordPtr
@@ -1227,6 +1228,9 @@ instance Data a => Data (Ptr a) where
   dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr"
   dataCast1 x  = gcast1 x
 
+-- | @since 4.18.0.0
+deriving instance Data a => Data (ConstPtr a)
+
 ------------------------------------------------------------------------------
 
 -- | @since 4.8.0.0
diff --git a/libraries/base/Foreign/C/ConstPtr.hs b/libraries/base/Foreign/C/ConstPtr.hs
new file mode 100644
index 0000000000..5e5d06cf95
--- /dev/null
+++ b/libraries/base/Foreign/C/ConstPtr.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Foreign.C.ConstPtr
+-- Copyright   :  (c) GHC Developers
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- This module provides typed @const@ pointers to foreign data. It is part
+-- of the Foreign Function Interface (FFI).
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.ConstPtr (
+    ConstPtr(..)
+) where
+
+import GHC.Base
+import GHC.Ptr
+import GHC.Show
+
+-- | A pointer with the C @const@ qualifier. For instance, an argument of type
+-- @ConstPtr CInt@ would be marshalled as @const int*@.
+--
+-- While @const@-ness generally does not matter for @ccall@ imports (since
+-- @const@ and non-@const@ pointers typically have equivalent calling
+-- conventions), it does matter for @capi@ imports. See GHC #22043.
+--
+-- @since 4.18.0.0
+--
+type ConstPtr :: Type -> Type
+type role ConstPtr phantom
+newtype ConstPtr a = ConstPtr { unConstPtr :: Ptr a }
+    deriving (Eq, Ord)
+
+-- doesn't use record syntax
+instance Show (ConstPtr a) where
+    showsPrec d (ConstPtr p) = showParen (d > 10) $ showString "ConstPtr " . showsPrec 11 p
diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs
index 844ec7a494..25d8cf1b02 100644
--- a/libraries/base/Foreign/Storable.hs
+++ b/libraries/base/Foreign/Storable.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -42,6 +45,7 @@ import GHC.Word
 import GHC.Ptr
 import GHC.Base
 import GHC.Fingerprint.Type
+import Foreign.C.ConstPtr
 import Data.Bits
 import GHC.Real
 
@@ -280,3 +284,5 @@ pokeFingerprint p0 (Fingerprint high low) = do
 
       pokeW64 (castPtr p0) 8 high
       pokeW64 (castPtr p0 `plusPtr` 8) 8 low
+
+deriving newtype instance Storable (ConstPtr a)
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index a57335db1d..d615108c58 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -169,6 +169,7 @@ Library
         Debug.Trace
         Foreign
         Foreign.C
+        Foreign.C.ConstPtr
         Foreign.C.Error
         Foreign.C.String
         Foreign.C.Types
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index ccc28ad322..b005d03617 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -1,9 +1,11 @@
 # Changelog for [`base` package](http://hackage.haskell.org/package/base)
 
 ## 4.18.0.0 *TBA*
+  * `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified
+    pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117))
   * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91))
-  * Add `Functor` instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
-    `(,,,,,) a b c d e f`
+  * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
+    `(,,,,,) a b c d e f`.
   * Exceptions thrown by weak pointer finalizers are now reported via a global
     exception handler.
   * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which allows the
@@ -42,7 +44,7 @@
     ([CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90))
   * Add `Eq` and `Ord` instances for `Generically1`.
   * Relax instances for Functor combinators; put superclass on Class1 and Class2
-    to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10), 
+    to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10),
     [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md))
   * Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation.
   * `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`,
diff --git a/testsuite/tests/ffi/should_compile/T22043.h b/testsuite/tests/ffi/should_compile/T22043.h
new file mode 100644
index 0000000000..26c49d3a38
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22043.h
@@ -0,0 +1,2 @@
+const int *foo();
+const double *bar;
diff --git a/testsuite/tests/ffi/should_compile/T22043.hs b/testsuite/tests/ffi/should_compile/T22043.hs
new file mode 100644
index 0000000000..4e2b7b7e0c
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22043.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE CApiFFI #-}
+module T22043 where
+
+import Foreign.C.Types
+import Foreign.C.ConstPtr
+
+foreign import capi "T22043.h foo"
+    c_foo :: IO (ConstPtr CInt)
+
+foreign import capi "T22043.h value bar"
+    c_bar :: ConstPtr CDouble
diff --git a/testsuite/tests/ffi/should_compile/T22043_c.c b/testsuite/tests/ffi/should_compile/T22043_c.c
new file mode 100644
index 0000000000..e70b5a978f
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22043_c.c
@@ -0,0 +1,9 @@
+#include <stdlib.h>
+
+const int * foo() {
+    int *x = malloc(sizeof(int));
+    *x = 42;
+    return x;
+}
+
+const int *bar = 0;
diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T
index d8afeb9f7b..6b4c557a07 100644
--- a/testsuite/tests/ffi/should_compile/all.T
+++ b/testsuite/tests/ffi/should_compile/all.T
@@ -43,3 +43,4 @@ test(
     ],
 )
 test('T15531', normal, compile, ['-Wall'])
+test('T22043', [omit_ways(['ghci'])], compile, [''])