diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index a8fcf61f2..c95260000 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/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 diff --git a/hs-bindgen/src-internal/HsBindgen/Backend/Extensions.hs b/hs-bindgen/src-internal/HsBindgen/Backend/Extensions.hs index dacfedd5c..a129c1f34 100644 --- a/hs-bindgen/src-internal/HsBindgen/Backend/Extensions.hs +++ b/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) diff --git a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs b/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs index e5fcc8225..bdc1bcaca 100644 --- a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs +++ b/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) *** diff --git a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ForeignImport.hs b/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ForeignImport.hs new file mode 100644 index 000000000..dbef42a4a --- /dev/null +++ b/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 + } diff --git a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ToFromFunPtr.hs b/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ToFromFunPtr.hs index bbcbbff36..d3af4b289 100644 --- a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/ToFromFunPtr.hs +++ b/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