Skip to content

Commit 891c7cf

Browse files
jorisdraljorisdral
committed
Add foreignImportDecs
This function is intended to be a type of smart constructor, even thought it is currently just a shallow wrapper around the `ForeignImportDecl` constructor. This will change as we resolve issue #1282.
1 parent dac9ae6 commit 891c7cf

File tree

5 files changed

+111
-67
lines changed

5 files changed

+111
-67
lines changed

‎hs-bindgen/hs-bindgen.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,7 @@ library internal
8686
HsBindgen.Backend.Hs.Origin
8787
HsBindgen.Backend.Hs.Translation
8888
HsBindgen.Backend.Hs.Translation.Config
89+
HsBindgen.Backend.Hs.Translation.ForeignImport
8990
HsBindgen.Backend.Hs.Translation.ToFromFunPtr
9091
HsBindgen.Backend.Hs.Translation.Type
9192
HsBindgen.Backend.HsModule.Capi

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,10 @@ requiredExtensions = \case
7676
nestedDeriving :: [(Strategy ClosedType, [Global])] -> Set TH.Extension
7777
nestedDeriving deriv =
7878
Set.singleton TH.DerivingStrategies
79-
<> mconcat (map (strategyExtensions . fst) deriv)
79+
<> mconcat [
80+
strategyExtensions s <> foldMap globalExtensions gs
81+
| (s, gs) <- deriv
82+
]
8083

8184
recordExtensions :: Record -> Set TH.Extension
8285
recordExtensions r = foldMap fieldExtensions (dataFields r)

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

Lines changed: 29 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
2020
import HsBindgen.Backend.Hs.Haddock.Translation
2121
import HsBindgen.Backend.Hs.Origin qualified as Origin
2222
import HsBindgen.Backend.Hs.Translation.Config
23+
import HsBindgen.Backend.Hs.Translation.ForeignImport qualified as HsFI
2324
import HsBindgen.Backend.Hs.Translation.ToFromFunPtr qualified as ToFromFunPtr
2425
import HsBindgen.Backend.Hs.Translation.Type qualified as Type
2526
import HsBindgen.Backend.SHs.AST
@@ -1437,31 +1438,31 @@ functionDecs ::
14371438
-> C.Function
14381439
-> C.DeclSpec
14391440
-> [Hs.Decl]
1440-
functionDecs safety opts haddockConfig moduleName info f _spec =
1441-
funDecl : [
1442-
hsWrapperDeclFunction highlevelName importName res wrappedArgTypes wrapParsedArgs f mbWrapComment
1441+
functionDecs safety opts haddockConfig moduleName info f _spec = concat [
1442+
funDecls
1443+
, [ hsWrapperDeclFunction highlevelName importName res wrappedArgTypes wrapParsedArgs f mbWrapComment
14431444
| areFancy
14441445
]
1446+
]
14451447
where
14461448
areFancy = anyFancy (res : wrappedArgTypes)
1447-
funDecl :: Hs.Decl
1448-
funDecl = Hs.DeclForeignImport $ Hs.ForeignImportDecl
1449-
{ foreignImportName = importName
1450-
, foreignImportResultType = snd resType
1451-
, foreignImportParameters = if areFancy then ffiParams else ffiParsedArgs
1452-
, foreignImportOrigName = uniqueCName wrapperName
1453-
, foreignImportCallConv = CallConvUserlandCAPI userlandCapiWrapper
1454-
, foreignImportOrigin = Origin.Function f
1455-
, foreignImportSafety = safety
1456-
1457-
, foreignImportComment = mconcat [
1449+
funDecls :: [Hs.Decl]
1450+
funDecls =
1451+
HsFI.foreignImportDecs
1452+
importName
1453+
(snd resType)
1454+
(if areFancy then ffiParams else ffiParsedArgs)
1455+
(uniqueCName wrapperName)
1456+
(CallConvUserlandCAPI userlandCapiWrapper)
1457+
(Origin.Function f)
1458+
(mconcat [
14581459
if areFancy
14591460
then Just nonFancyComment
14601461
else mbFFIComment
14611462
, ioComment
14621463
, Just $ HsDoc.uniqueSymbol wrapperName
1463-
]
1464-
}
1464+
])
1465+
safety
14651466

14661467
userlandCapiWrapper :: UserlandCapiWrapper
14671468
userlandCapiWrapper = UserlandCapiWrapper {
@@ -1745,7 +1746,7 @@ addressStubDecs ::
17451746
, Hs.Name 'Hs.NsVar
17461747
)
17471748
addressStubDecs opts haddockConfig moduleName info ty _spec =
1748-
(foreignImport : runnerDecls, runnerName)
1749+
(foreignImport ++ runnerDecls, runnerName)
17491750
where
17501751
-- *** Stub (impure) ***
17511752

@@ -1789,21 +1790,20 @@ addressStubDecs opts haddockConfig moduleName info ty _spec =
17891790

17901791
mbComment = generateHaddocksWithInfo haddockConfig info
17911792

1792-
foreignImport :: Hs.Decl
1793-
foreignImport = Hs.DeclForeignImport $ Hs.ForeignImportDecl
1794-
{ foreignImportName = stubImportName
1795-
, foreignImportParameters = []
1796-
, foreignImportResultType = stubImportType
1797-
, foreignImportOrigName = uniqueCName stubName
1798-
, foreignImportCallConv = CallConvUserlandCAPI userlandCapiWrapper
1799-
, foreignImportOrigin = Origin.Global ty
1800-
, foreignImportComment = Just $ HsDoc.uniqueSymbol stubName
1801-
1793+
foreignImport :: [Hs.Decl]
1794+
foreignImport =
1795+
HsFI.foreignImportDecs
1796+
stubImportName
1797+
stubImportType
1798+
[]
1799+
(uniqueCName stubName)
1800+
(CallConvUserlandCAPI userlandCapiWrapper)
1801+
(Origin.Global ty)
1802+
(Just $ HsDoc.uniqueSymbol stubName)
18021803
-- These imports can be unsafe. We're binding to simple address stubs,
18031804
-- so there are no callbacks into Haskell code. Moreover, they are
18041805
-- short running code.
1805-
, foreignImportSafety = SHs.Unsafe
1806-
}
1806+
SHs.Unsafe
18071807

18081808
-- *** Stub (pure) ***
18091809

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

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
-- | Generate Haskell foreign imports
2+
module HsBindgen.Backend.Hs.Translation.ForeignImport (
3+
foreignImportDecs
4+
) where
5+
6+
import HsBindgen.Backend.Hs.AST qualified as Hs
7+
import HsBindgen.Backend.Hs.AST.Type
8+
import HsBindgen.Backend.Hs.CallConv
9+
import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
10+
import HsBindgen.Backend.Hs.Origin qualified as Origin
11+
import HsBindgen.Backend.SHs.AST
12+
import HsBindgen.Frontend.Naming qualified as C
13+
import HsBindgen.Language.Haskell qualified as Hs
14+
15+
foreignImportDecs ::
16+
Hs.Name 'Hs.NsVar
17+
-> HsType
18+
-> [Hs.FunctionParameter]
19+
-> C.Name
20+
-> CallConv
21+
-> Origin.ForeignImport
22+
-> Maybe HsDoc.Comment
23+
-> Safety
24+
-> [Hs.Decl]
25+
foreignImportDecs name resultType parameters origName callConv origin comment safety =
26+
[ Hs.DeclForeignImport foreignImportDecl ]
27+
-- TODO: prevent the "newtype constructor not in scope" bug. See issue #1282.
28+
where
29+
foreignImportDecl :: Hs.ForeignImportDecl
30+
foreignImportDecl = Hs.ForeignImportDecl
31+
{ foreignImportName = name
32+
, foreignImportResultType = resultType
33+
, foreignImportParameters = parameters
34+
, foreignImportOrigName = origName
35+
, foreignImportCallConv = callConv
36+
, foreignImportOrigin = origin
37+
, foreignImportComment = comment
38+
, foreignImportSafety = safety
39+
}

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

Lines changed: 38 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ import HsBindgen.Backend.Hs.AST.Type
1515
import HsBindgen.Backend.Hs.CallConv
1616
import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
1717
import HsBindgen.Backend.Hs.Origin qualified as Origin
18+
import HsBindgen.Backend.Hs.Translation.ForeignImport qualified as HsFI
1819
import HsBindgen.Backend.Hs.Translation.Type qualified as Type
1920
import HsBindgen.Backend.HsModule.Render ()
2021
import HsBindgen.Backend.SHs.AST qualified as SHs
@@ -80,50 +81,50 @@ instancesFor ::
8081
-> C.Type -- ^ Type of the C function
8182
-> HsType -- ^ Corresponding Haskell type
8283
-> [Hs.Decl]
83-
instancesFor (nameTo, nameToComment) (nameFrom, nameFromComment) funC funHs = [
84+
instancesFor (nameTo, nameToComment) (nameFrom, nameFromComment) funC funHs = concat [
8485
-- import for @ToFunPtr@ instance
85-
Hs.DeclForeignImport Hs.ForeignImportDecl{
86-
foreignImportName = nameTo
87-
, foreignImportResultType = HsIO (HsFunPtr funHs)
88-
, foreignImportParameters = [wrapperParam funHs]
89-
, foreignImportOrigName = "wrapper"
90-
, foreignImportCallConv = CallConvGhcCCall ImportAsValue
91-
, foreignImportOrigin = Origin.ToFunPtr funC
92-
, foreignImportComment = nameToComment
93-
, foreignImportSafety = SHs.Safe
94-
}
86+
HsFI.foreignImportDecs
87+
nameTo
88+
(HsIO (HsFunPtr funHs))
89+
[wrapperParam funHs]
90+
"wrapper"
91+
(CallConvGhcCCall ImportAsValue)
92+
(Origin.ToFunPtr funC)
93+
nameToComment
94+
SHs.Safe
9595

9696
-- import for @FromFunPtr@ instance
97-
, Hs.DeclForeignImport Hs.ForeignImportDecl{
98-
foreignImportName = nameFrom
99-
, foreignImportResultType = funHs
100-
, foreignImportParameters = [wrapperParam $ HsFunPtr funHs]
101-
, foreignImportOrigName = "dynamic"
102-
, foreignImportCallConv = CallConvGhcCCall ImportAsValue
103-
, foreignImportOrigin = Origin.FromFunPtr funC
104-
, foreignImportComment = nameFromComment
105-
, foreignImportSafety = SHs.Safe
106-
}
97+
, HsFI.foreignImportDecs
98+
nameFrom
99+
funHs
100+
[wrapperParam $ HsFunPtr funHs]
101+
"wrapper"
102+
(CallConvGhcCCall ImportAsValue)
103+
(Origin.ToFunPtr funC)
104+
nameFromComment
105+
SHs.Safe
107106

108107
-- @ToFunPtr@ instance proper
109-
, Hs.DeclDefineInstance Hs.DefineInstance{
110-
defineInstanceComment = Nothing
111-
, defineInstanceDeclarations = Hs.InstanceToFunPtr
112-
Hs.ToFunPtrInstance{
113-
toFunPtrInstanceType = funHs
114-
, toFunPtrInstanceBody = nameTo
115-
}
116-
}
108+
, [ Hs.DeclDefineInstance Hs.DefineInstance{
109+
defineInstanceComment = Nothing
110+
, defineInstanceDeclarations = Hs.InstanceToFunPtr
111+
Hs.ToFunPtrInstance{
112+
toFunPtrInstanceType = funHs
113+
, toFunPtrInstanceBody = nameTo
114+
}
115+
}
116+
]
117117

118118
-- @FromFunPtr@ instance proper
119-
, Hs.DeclDefineInstance Hs.DefineInstance{
120-
defineInstanceComment = Nothing
121-
, defineInstanceDeclarations = Hs.InstanceFromFunPtr
122-
Hs.FromFunPtrInstance{
123-
fromFunPtrInstanceType = funHs
124-
, fromFunPtrInstanceBody = nameFrom
125-
}
126-
}
119+
, [ Hs.DeclDefineInstance Hs.DefineInstance{
120+
defineInstanceComment = Nothing
121+
, defineInstanceDeclarations = Hs.InstanceFromFunPtr
122+
Hs.FromFunPtrInstance{
123+
fromFunPtrInstanceType = funHs
124+
, fromFunPtrInstanceBody = nameFrom
125+
}
126+
}
127+
]
127128
]
128129

129130
wrapperParam :: HsType -> Hs.FunctionParameter

0 commit comments

Comments
 (0)