Skip to content

Commit 5e9a4e6

Browse files
jorisdraljorisdral
committed
WIP
1 parent 13c912b commit 5e9a4e6

File tree

12 files changed

+615
-205
lines changed

12 files changed

+615
-205
lines changed

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

Lines changed: 6 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)
@@ -91,6 +94,8 @@ globalExtensions = \case
9194
HasCBitfield_bitWidth# -> Set.singleton TH.MagicHash
9295
NomEq_class -> Set.singleton TH.TypeOperators
9396
HasField_class -> Set.singleton TH.UndecidableInstances
97+
Marshallable_class -> Set.singleton TH.UndecidableInstances
98+
BaseForeignType_type -> Set.singleton TH.UndecidableInstances
9499
_ -> mempty
95100

96101
exprExtensions :: SExpr ctx -> Set TH.Extension

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

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -128,27 +128,28 @@ data Newtype = Newtype {
128128
deriving stock (Generic, Show)
129129

130130
data ForeignImportDecl = ForeignImportDecl
131-
{ foreignImportName :: Hs.Name Hs.NsVar
132-
, foreignImportParameters :: [FunctionParameter]
133-
, foreignImportResultType :: HsType
134-
, foreignImportOrigName :: Text
135-
, foreignImportCallConv :: CallConv
136-
, foreignImportOrigin :: Origin.ForeignImport
137-
, foreignImportComment :: Maybe HsDoc.Comment
138-
, foreignImportSafety :: SHs.Safety
131+
{ foreignImportName :: Hs.Name Hs.NsVar
132+
, foreignImportParameters :: [FunctionParameter (Either HsType HsForeignArgType)]
133+
, foreignImportResultType :: Either HsType HsForeignResultType
134+
, foreignImportOrigName :: Text
135+
, foreignImportCallConv :: CallConv
136+
, foreignImportOrigin :: Origin.ForeignImport
137+
, foreignImportComment :: Maybe HsDoc.Comment
138+
, foreignImportSafety :: SHs.Safety
139139
}
140140
deriving stock (Generic, Show)
141141

142-
data FunctionParameter = FunctionParameter
142+
data FunctionParameter t = FunctionParameter
143143
{ functionParameterName :: Maybe (Hs.Name Hs.NsVar)
144-
, functionParameterType :: HsType
144+
, functionParameterType :: t
145145
, functionParameterComment :: Maybe HsDoc.Comment
146146
}
147147
deriving stock (Generic, Show)
148+
deriving stock (Functor, Foldable, Traversable)
148149

149150
data FunctionDecl = FunctionDecl
150151
{ functionDeclName :: Hs.Name Hs.NsVar
151-
, functionDeclParameters :: [FunctionParameter]
152+
, functionDeclParameters :: [FunctionParameter HsType]
152153
, functionDeclResultType :: HsType
153154
, functionDeclBody :: SHs.ClosedExpr
154155
, functionDeclOrigin :: Origin.ForeignImport

‎hs-bindgen/src-internal/HsBindgen/Backend/Hs/AST/Type.hs‎

Lines changed: 107 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,24 @@
1+
{- HLINT ignore "Functor law" -}
2+
13
module HsBindgen.Backend.Hs.AST.Type (
24
HsPrimType (..),
5+
HsTypRefKind (..),
36
HsType (..),
7+
-- * Foreign types
8+
HsForeignType(..),
9+
HsForeignResultType(..),
10+
HsForeignArgType(..),
11+
-- * Foreign types: parsing utils
12+
withEscapeHatch,
13+
withEscapeHatchF,
14+
-- * Foreign types: parsing
15+
isForeignType,
16+
isForeignResultType,
17+
isForeignArgType,
418
) where
519

20+
import HsBindgen.Runtime.IsForeignType as RT
21+
622
import HsBindgen.BindingSpec qualified as BindingSpec
723
import HsBindgen.Imports
824
import HsBindgen.Language.Haskell qualified as Hs
@@ -48,9 +64,17 @@ data HsPrimType
4864
-- Word8 Word16 Word32 Word64
4965
deriving stock (Eq, Ord, Generic, Show)
5066

67+
data HsTypRefKind =
68+
HsTypRefKindUnion
69+
| HsTypRefKindStruct
70+
| HsTypRefKindMacro
71+
| HsTypRefKindEnum
72+
| HsTypRefKindTypedef HsType -- ^ Underlying type
73+
deriving stock (Generic, Show, Eq)
74+
5175
data HsType =
5276
HsPrimType HsPrimType
53-
| HsTypRef (Hs.Name Hs.NsTypeConstr)
77+
| HsTypRef (Hs.Name Hs.NsTypeConstr) HsTypRefKind
5478
| HsConstArray Natural HsType
5579
| HsIncompleteArray HsType
5680
| HsPtr HsType
@@ -65,3 +89,85 @@ data HsType =
6589
| HsStrLit String
6690
deriving stock (Generic, Show, Eq)
6791

92+
{-------------------------------------------------------------------------------
93+
Foreign types
94+
-------------------------------------------------------------------------------}
95+
96+
newtype HsForeignType = HsForeignType { unHsForeignType :: RT.ForeignType }
97+
deriving stock (Show, Eq)
98+
99+
newtype HsForeignResultType = HsForeignResultType { unHsForeignResultType :: RT.ForeignResultType }
100+
deriving stock (Show, Eq)
101+
102+
newtype HsForeignArgType = HsForeignArgType { unHsForeignArgType :: RT.ForeignArgType }
103+
deriving stock (Show, Eq)
104+
105+
{-------------------------------------------------------------------------------
106+
Foreign types: parsing utils
107+
-------------------------------------------------------------------------------}
108+
109+
withEscapeHatchF :: Functor f => (f a -> Either s (f b)) -> f a -> f (Either a b)
110+
withEscapeHatchF f x = case f x of
111+
Left _ -> Left <$> x
112+
Right y -> Right <$> y
113+
114+
withEscapeHatch :: (a -> Either s b) -> a -> (Either a b)
115+
withEscapeHatch f x = case f x of
116+
Left _s -> Left x
117+
Right y -> Right y
118+
119+
{-------------------------------------------------------------------------------
120+
Foreign types: parsing
121+
-------------------------------------------------------------------------------}
122+
123+
isForeignType :: HsType -> Either String HsForeignType
124+
isForeignType = fmap HsForeignType . \case
125+
HsFun x y -> FT_FunArrow <$> (unHsForeignArgType <$> isForeignArgType x)
126+
<*> (unHsForeignType <$> isForeignType y)
127+
x -> FT_FunResult <$> (unHsForeignResultType <$> isForeignResultType x)
128+
129+
isForeignResultType :: HsType -> Either String HsForeignResultType
130+
isForeignResultType = fmap HsForeignResultType . \case
131+
HsPrimType HsPrimUnit -> Right RT.FRT_Unit
132+
HsIO (HsPrimType HsPrimUnit) -> Right RT.FRT_IOUnit
133+
HsIO x -> RT.FRT_IO <$> (unHsForeignArgType <$> isForeignArgType x)
134+
x -> RT.FRT_Pure <$> (unHsForeignArgType <$> isForeignArgType x)
135+
136+
isForeignArgType :: HsType -> Either String HsForeignArgType
137+
isForeignArgType = \case
138+
HsPrimType x -> HsForeignArgType <$> go x
139+
HsPtr _ -> Right $ HsForeignArgType RT.FAT_Ptr
140+
HsFunPtr _ -> Right $ HsForeignArgType RT.FAT_FunPtr
141+
HsTypRef _ kind ->
142+
case kind of
143+
HsTypRefKindStruct -> Left "structs not supported"
144+
HsTypRefKindUnion -> Left "unions not supported"
145+
HsTypRefKindEnum -> Left "enums not supported"
146+
HsTypRefKindMacro -> Left "macros not supported"
147+
HsTypRefKindTypedef uTy -> isForeignArgType uTy
148+
HsBlock _ -> Right $ HsForeignArgType RT.FAT_Ptr
149+
HsExtBinding{} -> Left "external bindings not supported"
150+
_ -> Left "impossible foreign arg type"
151+
where
152+
go :: HsPrimType -> Either String RT.ForeignArgType
153+
go = \case
154+
HsPrimVoid -> Left "impossible foreign arg type"
155+
HsPrimUnit -> Left "impossible foreign arg type"
156+
HsPrimCChar -> Right RT.FAT_CChar
157+
HsPrimCSChar -> Right RT.FAT_CSChar
158+
HsPrimCUChar -> Right RT.FAT_CUChar
159+
HsPrimCInt -> Right RT.FAT_CInt
160+
HsPrimCUInt -> Right RT.FAT_CUInt
161+
HsPrimCShort -> Right RT.FAT_CShort
162+
HsPrimCUShort -> Right RT.FAT_CUShort
163+
HsPrimCLong -> Right RT.FAT_CLong
164+
HsPrimCULong -> Right RT.FAT_CULong
165+
HsPrimCPtrDiff -> Right RT.FAT_CPtrdiff
166+
HsPrimCSize -> Right RT.FAT_CSize
167+
HsPrimCLLong -> Right RT.FAT_CLLong
168+
HsPrimCULLong -> Right RT.FAT_CULLong
169+
HsPrimCBool -> Right RT.FAT_CBool
170+
HsPrimCFloat -> Right RT.FAT_CFloat
171+
HsPrimCDouble -> Right RT.FAT_CDouble
172+
HsPrimCStringLen -> Left "impossible foreign arg type"
173+
HsPrimInt -> Right RT.FAT_Int

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

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -44,8 +44,8 @@ generateHaddocksWithFieldInfo config DeclInfo{..} FieldInfo{..} =
4444
generateHaddocksWithInfoParams
4545
:: HaddockConfig
4646
-> DeclInfo
47-
-> [Hs.FunctionParameter]
48-
-> (Maybe HsDoc.Comment, [Hs.FunctionParameter])
47+
-> [Hs.FunctionParameter t]
48+
-> (Maybe HsDoc.Comment, [Hs.FunctionParameter t])
4949
generateHaddocksWithInfoParams config DeclInfo{..} params =
5050
generateHaddocksWithParams config False declLoc declHeaderInfo declId declOrigin declComment params
5151

@@ -58,15 +58,15 @@ generateHaddocksWithInfoParams config DeclInfo{..} params =
5858
-- Returns the processed comment and the updated parameters list
5959
--
6060
generateHaddocksWithParams ::
61-
HaddockConfig
61+
forall t. HaddockConfig
6262
-> Bool
6363
-> C.SingleLoc
6464
-> Maybe HeaderInfo
6565
-> NamePair
6666
-> NameOrigin
6767
-> Maybe (CDoc.Comment CommentRef)
68-
-> [Hs.FunctionParameter]
69-
-> (Maybe HsDoc.Comment, [Hs.FunctionParameter])
68+
-> [Hs.FunctionParameter t]
69+
-> (Maybe HsDoc.Comment, [Hs.FunctionParameter t])
7070
generateHaddocksWithParams HaddockConfig{..} isField declLoc mHeaderInfo declId declOrigin Nothing params =
7171
let (commentCName, commentLocation) =
7272
case declOrigin of
@@ -178,13 +178,13 @@ generateHaddocksWithParams HaddockConfig{..} isField declLoc mHeaderInfo declId
178178
-- Process 'C.ParamCommand and update matching parameter
179179
--
180180
processParamCommands :: [(HsDoc.Comment, Maybe CDoc.CXCommentParamPassDirection)]
181-
-> [Hs.FunctionParameter]
181+
-> [Hs.FunctionParameter t]
182182
processParamCommands paramCmds =
183183
go paramCmds params
184184
where
185185
go :: [(HsDoc.Comment, Maybe CDoc.CXCommentParamPassDirection)]
186-
-> [Hs.FunctionParameter]
187-
-> [Hs.FunctionParameter]
186+
-> [Hs.FunctionParameter t]
187+
-> [Hs.FunctionParameter t]
188188
go [] currentParams = currentParams
189189
go ((hsComment, _mbDirection):rest) currentParams =
190190
let updatedParams =
@@ -199,7 +199,7 @@ generateHaddocksWithParams HaddockConfig{..} isField declLoc mHeaderInfo declId
199199
-- | If the function parameter doesn't have any comments then add a simple
200200
-- comment with just its name (if exists).
201201
--
202-
addFunctionParameterComment :: Hs.FunctionParameter -> Hs.FunctionParameter
202+
addFunctionParameterComment :: Hs.FunctionParameter t -> Hs.FunctionParameter t
203203
addFunctionParameterComment fp@Hs.FunctionParameter {..} =
204204
case functionParameterName of
205205
Nothing -> fp

0 commit comments

Comments
 (0)