Skip to content

Commit a260ffd

Browse files
TravisCardwellTravisCardwell
committed
Implement Haskell AST annotations (demo)
1 parent 3d2027b commit a260ffd

File tree

5 files changed

+141
-72
lines changed

5 files changed

+141
-72
lines changed

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

Lines changed: 97 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,11 @@
1818
--
1919
-- > import HsBindgen.Hs.AST qualified as Hs
2020
module HsBindgen.Hs.AST (
21+
-- * Passes and Annotations
22+
Pass(..)
23+
, Ann
2124
-- * Information about generated code
22-
Struct(..)
25+
, Struct(..)
2326
, Newtype(..)
2427
-- * Types
2528
, HsType(..)
@@ -52,37 +55,65 @@ module HsBindgen.Hs.AST (
5255
, makeElimStruct
5356
) where
5457

55-
import HsBindgen.C.AST qualified as C (MFun(..))
56-
import HsBindgen.C.Tc.Macro qualified as C
5758
import Data.Type.Nat as Nat
59+
import GHC.Base (Symbol)
5860

61+
import HsBindgen.C.AST qualified as C (MFun(..))
62+
import HsBindgen.C.Tc.Macro qualified as C
5963
import HsBindgen.Imports
6064
import HsBindgen.NameHint
6165
import HsBindgen.Hs.AST.Name
6266
import HsBindgen.Hs.AST.Type
6367

6468
import DeBruijn
6569

70+
{-------------------------------------------------------------------------------
71+
Passes and annotations
72+
-------------------------------------------------------------------------------}
73+
74+
-- | Passes for the Haskell AST phase
75+
data Pass = Placeholder
76+
77+
-- | Symbol-indexed annotations for a given pass
78+
type family Ann (pass :: Pass) (s :: Symbol) where
79+
Ann Placeholder s = AnnPlaceholder s
80+
81+
-- | Symbol-indexed annotations for the 'Placeholder' pass
82+
type family AnnPlaceholder (s :: Symbol) where
83+
AnnPlaceholder s = ()
84+
85+
-- Class alias to work around GHC limitation that type family synonym
86+
-- applications cannot be used in quantified constraints
87+
class Show (Ann pass s) => ShowAnn pass s
88+
instance Show (Ann pass s) => ShowAnn pass s
89+
90+
-- All annotations must have a 'Show' instance (quantified constraint)
91+
class (forall s. ShowAnn pass s) => AllAnnShow pass
92+
instance (forall s. ShowAnn pass s) => AllAnnShow pass
93+
6694
{-------------------------------------------------------------------------------
6795
Information about generated code
6896
-------------------------------------------------------------------------------}
6997

70-
data Struct (n :: Nat) = Struct {
71-
structName :: HsName NsTypeConstr
98+
data Struct (pass :: Pass) (n :: Nat) = Struct {
99+
structAnn :: Ann pass "Struct"
100+
, structName :: HsName NsTypeConstr
72101
, structConstr :: HsName NsConstr
73-
, structFields :: Vec n (HsName NsVar, HsType)
102+
, structFields :: Vec n (Ann pass "StructField", (HsName NsVar, HsType))
74103
}
75104

76-
deriving stock instance Show (Struct n)
105+
deriving stock instance AllAnnShow pass => Show (Struct pass n)
77106

78-
data Newtype = Newtype {
79-
newtypeName :: HsName NsTypeConstr
80-
, newtypeConstr :: HsName NsConstr
81-
, newtypeField :: HsName NsVar
82-
, newtypeType :: HsType
107+
data Newtype (pass :: Pass) = Newtype {
108+
newtypeAnn :: Ann pass "Newtype"
109+
, newtypeName :: HsName NsTypeConstr
110+
, newtypeConstr :: HsName NsConstr
111+
, newtypeFieldAnn :: Ann pass "NewtypeField"
112+
, newtypeField :: HsName NsVar
113+
, newtypeType :: HsType
83114
}
84115

85-
deriving stock instance Show Newtype
116+
deriving stock instance AllAnnShow pass => Show (Newtype pass)
86117

87118
{-------------------------------------------------------------------------------
88119
Variable binding
@@ -106,28 +137,31 @@ data Ap pure xs ctx = Ap (pure ctx) [xs ctx]
106137
-------------------------------------------------------------------------------}
107138

108139
-- | Top-level declaration
109-
type Decl :: Star
110-
data Decl where
111-
DeclData :: SNatI n => Struct n -> Decl
112-
DeclEmpty :: HsName NsTypeConstr -> Decl
113-
DeclNewtype :: Newtype -> Decl
114-
DeclInstance :: InstanceDecl -> Decl
115-
DeclNewtypeInstance :: TypeClass -> HsName NsTypeConstr -> Decl
116-
DeclVar :: VarDecl -> Decl
140+
type Decl :: Pass -> Star
141+
data Decl pass where
142+
DeclData :: SNatI n => Struct pass n -> Decl pass
143+
DeclEmpty :: HsName NsTypeConstr -> Decl pass
144+
DeclNewtype :: Newtype pass -> Decl pass
145+
DeclInstance :: InstanceDecl pass -> Decl pass
146+
DeclNewtypeInstance :: TypeClass -> HsName NsTypeConstr -> Decl pass
147+
DeclVar :: VarDecl -> Decl pass
117148

118-
deriving instance Show Decl
149+
deriving instance AllAnnShow pass => Show (Decl pass)
119150

120151
-- | Class instance names
121152
data TypeClass =
122153
Storable
123154
deriving stock (Show)
124155

125156
-- | Class instance declaration
126-
type InstanceDecl :: Star
127-
data InstanceDecl where
128-
InstanceStorable :: Struct n -> StorableInstance -> InstanceDecl
157+
type InstanceDecl :: Pass -> Star
158+
data InstanceDecl pass where
159+
InstanceStorable ::
160+
Struct pass n
161+
-> StorableInstance pass
162+
-> InstanceDecl pass
129163

130-
deriving instance Show InstanceDecl
164+
deriving instance AllAnnShow pass => Show (InstanceDecl pass)
131165

132166
-- | Variable or function declaration.
133167
type VarDecl :: Star
@@ -214,15 +248,16 @@ deriving stock instance Show VarDeclRHSAppHead
214248
-- Currently this models storable instances for structs /only/.
215249
--
216250
-- <https://hackage.haskell.org/package/base/docs/Foreign-Storable.html#t:Storable>
217-
type StorableInstance :: Star
218-
data StorableInstance = StorableInstance
251+
type StorableInstance :: Pass -> Star
252+
data StorableInstance pass = StorableInstance
219253
{ storableSizeOf :: Int
220254
, storableAlignment :: Int
221-
, storablePeek :: Lambda (Ap StructCon PeekByteOff) EmptyCtx
222-
, storablePoke :: Lambda (Lambda (ElimStruct (Seq PokeByteOff))) EmptyCtx
255+
, storablePeek :: Lambda (Ap (StructCon pass) PeekByteOff) EmptyCtx
256+
, storablePoke ::
257+
Lambda (Lambda (ElimStruct pass (Seq PokeByteOff))) EmptyCtx
223258
}
224259

225-
deriving instance Show StorableInstance
260+
deriving instance AllAnnShow pass => Show (StorableInstance pass)
226261

227262
-- | Call to 'peekByteOff'
228263
--
@@ -252,28 +287,48 @@ newtype Seq t ctx = Seq [t ctx]
252287
Structs
253288
-------------------------------------------------------------------------------}
254289

255-
type StructCon :: Ctx -> Star
256-
data StructCon ctx where
257-
StructCon :: Struct n -> StructCon ctx
290+
type StructCon :: Pass -> Ctx -> Star
291+
data StructCon pass ctx where
292+
StructCon :: Struct pass n -> StructCon pass ctx
258293

259-
deriving instance Show (StructCon ctx)
294+
deriving instance AllAnnShow pass => Show (StructCon pass ctx)
260295

261296
-- | Case split for a struct
262-
type ElimStruct :: (Ctx -> Star) -> (Ctx -> Star)
263-
data ElimStruct t ctx where
264-
ElimStruct :: Idx ctx -> Struct n -> Add n ctx ctx' -> t ctx' -> ElimStruct t ctx
265-
266-
deriving instance (forall ctx'. Show (t ctx')) => Show (ElimStruct t ctx)
297+
type ElimStruct :: Pass -> (Ctx -> Star) -> (Ctx -> Star)
298+
data ElimStruct pass t ctx where
299+
ElimStruct ::
300+
Idx ctx
301+
-> Struct pass n
302+
-> Add n ctx ctx'
303+
-> t ctx'
304+
-> ElimStruct pass t ctx
305+
306+
deriving instance
307+
(AllAnnShow pass, forall ctx'. Show (t ctx'))
308+
=> Show (ElimStruct pass t ctx)
267309

268310
-- | Create 'ElimStruct' using kind-of HOAS interface.
269311
--
270-
makeElimStruct :: forall n ctx t. SNatI n => Idx ctx -> Struct n -> (forall ctx'. Wk ctx ctx' -> Vec n (Idx ctx') -> t ctx') -> ElimStruct t ctx
312+
makeElimStruct :: forall n ctx t pass.
313+
SNatI n
314+
=> Idx ctx
315+
-> Struct pass n
316+
-> (forall ctx'. Wk ctx ctx' -> Vec n (Idx ctx') -> t ctx')
317+
-> ElimStruct pass t ctx
271318
makeElimStruct s struct kont = makeElimStruct' (snat :: SNat n) $ \add wk xs ->
272319
ElimStruct s struct add (kont wk xs)
273320

274321
--
275322
-- TODO: use Data.Type.Nat.induction instead of explicit recursion.
276323
-- TODO: verify that we bind fields in right order.
277-
makeElimStruct' :: forall m ctx t. SNat m -> (forall ctx'. Add m ctx ctx' -> Wk ctx ctx' -> Vec m (Idx ctx') -> ElimStruct t ctx) -> ElimStruct t ctx
324+
makeElimStruct' :: forall m ctx t pass.
325+
SNat m
326+
-> ( forall ctx'.
327+
Add m ctx ctx'
328+
-> Wk ctx ctx'
329+
-> Vec m (Idx ctx')
330+
-> ElimStruct pass t ctx
331+
)
332+
-> ElimStruct pass t ctx
278333
makeElimStruct' Nat.SZ kont = kont AZ IdWk VNil
279334
makeElimStruct' (Nat.SS' n) kont = makeElimStruct' n $ \add wk xs -> kont (AS add) (SkipWk wk) (IZ ::: fmap IS xs)

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

Lines changed: 27 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ import DeBruijn (Idx (..), pattern I1, weaken, Add (..), pattern I2, EmptyCtx, S
3636
Top-level
3737
-------------------------------------------------------------------------------}
3838

39-
generateDeclarations :: C.Header -> [Hs.Decl]
39+
generateDeclarations :: C.Header -> [Hs.Decl Hs.Placeholder]
4040
generateDeclarations = toHs
4141

4242
{-------------------------------------------------------------------------------
@@ -48,11 +48,11 @@ class ToHs (a :: Star) where
4848
toHs :: a -> InHs a
4949

5050
instance ToHs C.Header where
51-
type InHs C.Header = [Hs.Decl]
51+
type InHs C.Header = [Hs.Decl Hs.Placeholder]
5252
toHs (C.Header decs) = concatMap toHs decs
5353

5454
instance ToHs C.Decl where
55-
type InHs C.Decl = [Hs.Decl]
55+
type InHs C.Decl = [Hs.Decl Hs.Placeholder]
5656
toHs (C.DeclStruct struct) = reifyStructFields struct $ structDecs struct
5757
toHs (C.DeclOpaqueStruct n) = opaqueStructDecs n
5858
toHs (C.DeclEnum e) = enumDecs e
@@ -82,27 +82,28 @@ reifyStructFields struct k = Vec.reifyList (C.structFields struct) k
8282
-- * ..
8383
structDecs :: forall n.
8484
SNatI n
85-
=> C.Struct -> Vec n C.StructField -> [Hs.Decl]
85+
=> C.Struct -> Vec n C.StructField -> [Hs.Decl Hs.Placeholder]
8686
structDecs struct fields =
8787
[ Hs.DeclData hs
8888
, Hs.DeclInstance $ Hs.InstanceStorable hs storable
8989
]
9090
where
91-
hs :: Hs.Struct n
91+
hs :: Hs.Struct Hs.Placeholder n
9292
hs =
9393
let cStructName = fromMaybe "X" $ C.structTag struct
9494
nm@NameMangler{..} = defaultNameMangler
9595
typeConstrCtx = TypeConstrContext cStructName
96+
structAnn = ()
9697
structName = mangleTypeConstrName typeConstrCtx
9798
structConstr = mangleConstrName $ ConstrContext typeConstrCtx
98-
mkField f =
99+
mkField f = (,) () $
99100
( mangleVarName $ FieldVarContext typeConstrCtx True (C.fieldName f)
100101
, typ nm (C.fieldType f)
101102
)
102103
structFields = Vec.map mkField fields
103104
in Hs.Struct{..}
104105

105-
storable :: Hs.StorableInstance
106+
storable :: Hs.StorableInstance Hs.Placeholder
106107
storable = Hs.StorableInstance {
107108
Hs.storableSizeOf = C.structSizeof struct
108109
, Hs.storableAlignment = C.structAlignment struct
@@ -122,7 +123,7 @@ structDecs struct fields =
122123
Opaque struct
123124
-------------------------------------------------------------------------------}
124125

125-
opaqueStructDecs :: C.CName -> [Hs.Decl]
126+
opaqueStructDecs :: C.CName -> [Hs.Decl Hs.Placeholder]
126127
opaqueStructDecs cname =
127128
[ Hs.DeclEmpty hsName
128129
]
@@ -135,37 +136,40 @@ opaqueStructDecs cname =
135136
Enum
136137
-------------------------------------------------------------------------------}
137138

138-
enumDecs :: C.Enu -> [Hs.Decl]
139+
enumDecs :: C.Enu -> [Hs.Decl Hs.Placeholder]
139140
enumDecs e = [
140141
Hs.DeclNewtype newtype_
141142
, Hs.DeclInstance $ Hs.InstanceStorable hs storable
142143
]
143144
where
144-
newtype_ :: Hs.Newtype
145+
newtype_ :: Hs.Newtype Hs.Placeholder
145146
newtype_ =
146147
let cEnumName = fromMaybe "X" $ C.enumTag e
147148
nm@NameMangler{..} = defaultNameMangler
148149
typeConstrCtx = TypeConstrContext cEnumName
150+
newtypeAnn = ()
149151
newtypeName = mangleTypeConstrName typeConstrCtx
150152
newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
153+
newtypeFieldAnn = ()
151154
newtypeField = mangleVarName $ EnumVarContext typeConstrCtx
152155
newtypeType = typ nm (C.enumType e)
153156
in Hs.Newtype {..}
154157

155-
hs :: Hs.Struct (S Z)
158+
hs :: Hs.Struct Hs.Placeholder (S Z)
156159
hs =
157160
let cEnumName = fromMaybe "X" $ C.enumTag e
158161
nm@NameMangler{..} = defaultNameMangler
159162
typeConstrCtx = TypeConstrContext cEnumName
163+
structAnn = ()
160164
structName = mangleTypeConstrName typeConstrCtx
161165
structConstr = mangleConstrName $ ConstrContext typeConstrCtx
162-
structFields = Vec.singleton
166+
structFields = Vec.singleton . (,) () $
163167
( mangleVarName $ EnumVarContext typeConstrCtx
164168
, typ nm (C.enumType e)
165169
)
166170
in Hs.Struct{..}
167171

168-
storable :: Hs.StorableInstance
172+
storable :: Hs.StorableInstance Hs.Placeholder
169173
storable = Hs.StorableInstance {
170174
Hs.storableSizeOf = C.enumSizeof e
171175
, Hs.storableAlignment = C.enumAlignment e
@@ -185,7 +189,7 @@ enumDecs e = [
185189
Typedef
186190
-------------------------------------------------------------------------------}
187191

188-
typedefDecs :: C.Typedef -> [Hs.Decl]
192+
typedefDecs :: C.Typedef -> [Hs.Decl Hs.Placeholder]
189193
typedefDecs d = [
190194
Hs.DeclNewtype newtype_
191195
, Hs.DeclNewtypeInstance Hs.Storable newtypeName
@@ -194,9 +198,11 @@ typedefDecs d = [
194198
cName = C.typedefName d
195199
nm@NameMangler{..} = defaultNameMangler
196200
typeConstrCtx = TypeConstrContext cName
201+
newtypeAnn = ()
197202
newtypeName = mangleTypeConstrName typeConstrCtx
203+
newtypeFieldAnn = ()
198204

199-
newtype_ :: Hs.Newtype
205+
newtype_ :: Hs.Newtype Hs.Placeholder
200206
newtype_ = Hs.Newtype {..}
201207
where
202208
newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
@@ -207,7 +213,7 @@ typedefDecs d = [
207213
Macros
208214
-------------------------------------------------------------------------------}
209215

210-
macroDecs :: C.MacroDecl -> [Hs.Decl]
216+
macroDecs :: C.MacroDecl -> [Hs.Decl Hs.Placeholder]
211217
macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
212218
| C.QuantTy bf <- ty
213219
, C.isPrimTy bf
@@ -220,18 +226,20 @@ macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
220226
macroDecs C.MacroReparseError {} = []
221227
macroDecs C.MacroTcError {} = []
222228

223-
macroDecsTypedef :: C.Macro -> [Hs.Decl]
229+
macroDecsTypedef :: C.Macro -> [Hs.Decl Hs.Placeholder]
224230
macroDecsTypedef m = [
225231
Hs.DeclNewtype newtype_
226232
]
227233
where
228-
newtype_ :: Hs.Newtype
234+
newtype_ :: Hs.Newtype Hs.Placeholder
229235
newtype_ =
230236
let cName = C.macroName m
231237
nm@NameMangler{..} = defaultNameMangler
232238
typeConstrCtx = TypeConstrContext cName
239+
newtypeAnn = ()
233240
newtypeName = mangleTypeConstrName typeConstrCtx
234241
newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
242+
newtypeFieldAnn = ()
235243
newtypeField = mangleVarName $ EnumVarContext typeConstrCtx
236244

237245
-- TODO: this type conversion is very simple, but works for now.
@@ -280,7 +288,7 @@ floatingType = \case
280288
Macro
281289
-------------------------------------------------------------------------------}
282290

283-
macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl]
291+
macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl Hs.Placeholder]
284292
macroVarDecs (C.Macro { macroName = cVarNm, macroArgs = args, macroBody = body } ) qty =
285293
[
286294
Hs.DeclVar $

0 commit comments

Comments
 (0)