Add foreignImportDecs

hs-bindgen/hs-bindgen.cabal

@@ -86,6 +86,7 @@ library internal
     HsBindgen.Backend.Hs.Origin
     HsBindgen.Backend.Hs.Translation
     HsBindgen.Backend.Hs.Translation.Config
+    HsBindgen.Backend.Hs.Translation.ForeignImport
     HsBindgen.Backend.Hs.Translation.ToFromFunPtr
     HsBindgen.Backend.Hs.Translation.Type
     HsBindgen.Backend.HsModule.Capi

hs-bindgen/src-internal/HsBindgen/Backend/Extensions.hs

@@ -76,7 +76,10 @@ requiredExtensions = \case
 nestedDeriving :: [(Strategy ClosedType, [Global])] -> Set TH.Extension
 nestedDeriving deriv =
        Set.singleton TH.DerivingStrategies
-    <> mconcat (map (strategyExtensions . fst) deriv)
+    <> mconcat [
+          strategyExtensions s <> foldMap globalExtensions gs
+        | (s, gs) <- deriv
+        ]
 
 recordExtensions :: Record -> Set TH.Extension
 recordExtensions r = foldMap fieldExtensions (dataFields r)

hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs

@@ -20,6 +20,7 @@ import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
 import HsBindgen.Backend.Hs.Haddock.Translation
 import HsBindgen.Backend.Hs.Origin qualified as Origin
 import HsBindgen.Backend.Hs.Translation.Config
+import HsBindgen.Backend.Hs.Translation.ForeignImport qualified as HsFI
 import HsBindgen.Backend.Hs.Translation.ToFromFunPtr qualified as ToFromFunPtr
 import HsBindgen.Backend.Hs.Translation.Type qualified as Type
 import HsBindgen.Backend.SHs.AST
@@ -1425,31 +1426,31 @@ functionDecs ::
   -> C.Function
   -> C.DeclSpec
   -> [Hs.Decl]
-functionDecs safety opts haddockConfig moduleName info f _spec =
-    funDecl : [
-        hsWrapperDeclFunction highlevelName importName res wrappedArgTypes wrapParsedArgs f mbWrapComment
+functionDecs safety opts haddockConfig moduleName info f _spec = concat [
+      funDecls
+    , [ hsWrapperDeclFunction highlevelName importName res wrappedArgTypes wrapParsedArgs f mbWrapComment
       | areFancy
       ]
+    ]
   where
     areFancy = anyFancy (res : wrappedArgTypes)
-    funDecl :: Hs.Decl
-    funDecl = Hs.DeclForeignImport $ Hs.ForeignImportDecl
-        { foreignImportName       = importName
-        , foreignImportResultType = snd resType
-        , foreignImportParameters = if areFancy then ffiParams else ffiParsedArgs
-        , foreignImportOrigName   = uniqueCName wrapperName
-        , foreignImportCallConv   = CallConvUserlandCAPI userlandCapiWrapper
-        , foreignImportOrigin     = Origin.Function f
-        , foreignImportSafety     = safety
-
-        , foreignImportComment = mconcat [
+    funDecls :: [Hs.Decl]
+    funDecls =
+        HsFI.foreignImportDecs
+          importName
+          (snd resType)
+          (if areFancy then ffiParams else ffiParsedArgs)
+          (uniqueCName wrapperName)
+          (CallConvUserlandCAPI userlandCapiWrapper)
+          (Origin.Function f)
+          (mconcat [
               if areFancy
                 then Just nonFancyComment
                 else mbFFIComment
             , ioComment
             , Just $ HsDoc.uniqueSymbol wrapperName
-            ]
-        }
+            ])
+          safety
 
     userlandCapiWrapper :: UserlandCapiWrapper
     userlandCapiWrapper = UserlandCapiWrapper {
@@ -1733,7 +1734,7 @@ addressStubDecs ::
      , Hs.Name 'Hs.NsVar
      )
 addressStubDecs opts haddockConfig moduleName info ty _spec =
-    (foreignImport : runnerDecls, runnerName)
+    (foreignImport ++ runnerDecls, runnerName)
   where
     -- *** Stub (impure) ***
 
@@ -1777,21 +1778,20 @@ addressStubDecs opts haddockConfig moduleName info ty _spec =
 
     mbComment = generateHaddocksWithInfo haddockConfig info
 
-    foreignImport :: Hs.Decl
-    foreignImport = Hs.DeclForeignImport $ Hs.ForeignImportDecl
-        { foreignImportName       = stubImportName
-        , foreignImportParameters = []
-        , foreignImportResultType = stubImportType
-        , foreignImportOrigName   = uniqueCName stubName
-        , foreignImportCallConv   = CallConvUserlandCAPI userlandCapiWrapper
-        , foreignImportOrigin     = Origin.Global ty
-        , foreignImportComment    = Just $ HsDoc.uniqueSymbol stubName
-
+    foreignImport :: [Hs.Decl]
+    foreignImport =
+        HsFI.foreignImportDecs
+          stubImportName
+          stubImportType
+          []
+          (uniqueCName stubName)
+          (CallConvUserlandCAPI userlandCapiWrapper)
+          (Origin.Global ty)
+          (Just $ HsDoc.uniqueSymbol stubName)
           -- These imports can be unsafe. We're binding to simple address stubs,
           -- so there are no callbacks into Haskell code. Moreover, they are
           -- short running code.
-        , foreignImportSafety = SHs.Unsafe
-        }
+          SHs.Unsafe
 
     -- *** Stub (pure) ***
 

hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ForeignImport.hs

@@ -0,0 +1,39 @@
+-- | Generate Haskell foreign imports
+module HsBindgen.Backend.Hs.Translation.ForeignImport (
+    foreignImportDecs
+  ) where
+
+import HsBindgen.Backend.Hs.AST qualified as Hs
+import HsBindgen.Backend.Hs.AST.Type
+import HsBindgen.Backend.Hs.CallConv
+import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
+import HsBindgen.Backend.Hs.Origin qualified as Origin
+import HsBindgen.Backend.SHs.AST
+import HsBindgen.Frontend.Naming qualified as C
+import HsBindgen.Language.Haskell qualified as Hs
+
+foreignImportDecs ::
+     Hs.Name 'Hs.NsVar
+  -> HsType
+  -> [Hs.FunctionParameter]
+  -> C.Name
+  -> CallConv
+  -> Origin.ForeignImport
+  -> Maybe HsDoc.Comment
+  -> Safety
+  -> [Hs.Decl]
+foreignImportDecs name resultType parameters origName callConv origin comment safety =
+    [ Hs.DeclForeignImport foreignImportDecl ]
+    -- TODO: prevent the "newtype constructor not in scope" bug. See issue #1282.
+  where
+    foreignImportDecl :: Hs.ForeignImportDecl
+    foreignImportDecl =  Hs.ForeignImportDecl
+        { foreignImportName         = name
+        , foreignImportResultType   = resultType
+        , foreignImportParameters   = parameters
+        , foreignImportOrigName     = origName
+        , foreignImportCallConv     = callConv
+        , foreignImportOrigin       = origin
+        , foreignImportComment      = comment
+        , foreignImportSafety       = safety
+        }

hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ToFromFunPtr.hs

@@ -15,6 +15,7 @@ import HsBindgen.Backend.Hs.AST.Type
 import HsBindgen.Backend.Hs.CallConv
 import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
 import HsBindgen.Backend.Hs.Origin qualified as Origin
+import HsBindgen.Backend.Hs.Translation.ForeignImport qualified as HsFI
 import HsBindgen.Backend.Hs.Translation.Type qualified as Type
 import HsBindgen.Backend.HsModule.Render ()
 import HsBindgen.Backend.SHs.AST qualified as SHs
@@ -80,50 +81,50 @@ instancesFor ::
   -> C.Type                                  -- ^ Type of the C function
   -> HsType                                  -- ^ Corresponding Haskell type
   -> [Hs.Decl]
-instancesFor (nameTo, nameToComment) (nameFrom, nameFromComment) funC funHs = [
+instancesFor (nameTo, nameToComment) (nameFrom, nameFromComment) funC funHs = concat [
       -- import for @ToFunPtr@ instance
-      Hs.DeclForeignImport Hs.ForeignImportDecl{
-          foreignImportName       = nameTo
-        , foreignImportResultType = HsIO (HsFunPtr funHs)
-        , foreignImportParameters = [wrapperParam funHs]
-        , foreignImportOrigName   = "wrapper"
-        , foreignImportCallConv   = CallConvGhcCCall ImportAsValue
-        , foreignImportOrigin     = Origin.ToFunPtr funC
-        , foreignImportComment    = nameToComment
-        , foreignImportSafety     = SHs.Safe
-        }
+      HsFI.foreignImportDecs
+        nameTo
+        (HsIO (HsFunPtr funHs))
+        [wrapperParam funHs]
+        "wrapper"
+        (CallConvGhcCCall ImportAsValue)
+        (Origin.ToFunPtr funC)
+        nameToComment
+        SHs.Safe
 
       -- import for @FromFunPtr@ instance
-    , Hs.DeclForeignImport Hs.ForeignImportDecl{
-          foreignImportName       = nameFrom
-        , foreignImportResultType = funHs
-        , foreignImportParameters = [wrapperParam $ HsFunPtr funHs]
-        , foreignImportOrigName   = "dynamic"
-        , foreignImportCallConv   = CallConvGhcCCall ImportAsValue
-        , foreignImportOrigin     = Origin.FromFunPtr funC
-        , foreignImportComment    = nameFromComment
-        , foreignImportSafety     = SHs.Safe
-        }
+    , HsFI.foreignImportDecs
+        nameFrom
+        funHs
+        [wrapperParam $ HsFunPtr funHs]
+        "dynamic"
+        (CallConvGhcCCall ImportAsValue)
+        (Origin.ToFunPtr funC)
+        nameFromComment
+        SHs.Safe
 
       -- @ToFunPtr@ instance proper
-    , Hs.DeclDefineInstance Hs.DefineInstance{
-          defineInstanceComment      = Nothing
-        , defineInstanceDeclarations = Hs.InstanceToFunPtr
-            Hs.ToFunPtrInstance{
-                toFunPtrInstanceType = funHs
-              , toFunPtrInstanceBody = nameTo
-              }
-        }
+    , [ Hs.DeclDefineInstance Hs.DefineInstance{
+            defineInstanceComment      = Nothing
+          , defineInstanceDeclarations = Hs.InstanceToFunPtr
+              Hs.ToFunPtrInstance{
+                  toFunPtrInstanceType = funHs
+                , toFunPtrInstanceBody = nameTo
+                }
+          }
+      ]
 
       -- @FromFunPtr@ instance proper
-    , Hs.DeclDefineInstance Hs.DefineInstance{
-          defineInstanceComment      = Nothing
-        , defineInstanceDeclarations = Hs.InstanceFromFunPtr
-            Hs.FromFunPtrInstance{
-                fromFunPtrInstanceType = funHs
-              , fromFunPtrInstanceBody = nameFrom
-              }
-        }
+    , [ Hs.DeclDefineInstance Hs.DefineInstance{
+            defineInstanceComment      = Nothing
+          , defineInstanceDeclarations = Hs.InstanceFromFunPtr
+              Hs.FromFunPtrInstance{
+                  fromFunPtrInstanceType = funHs
+                , fromFunPtrInstanceBody = nameFrom
+                }
+          }
+      ]
     ]
 
 wrapperParam :: HsType -> Hs.FunctionParameter