Generate macro typedef declarations

hs-bindgen/fixtures/typedef_vs_macro.hs

@@ -1 +1 @@
-List {getList = [DeclNewtype (Newtype {newtypeName = "CT1", newtypeConstr = "MkCT1", newtypeField = "unCT1", newtypeType = HsPrimType HsPrimCInt}), DeclNewtype (Newtype {newtypeName = "CT2", newtypeConstr = "MkCT2", newtypeField = "unCT2", newtypeType = HsPrimType HsPrimCChar}), DeclData (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64, PeekByteOff x0 96]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (\(x1 ::: x2 ::: x3 ::: x4 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3, PokeByteOff x0 96 x4]}))))})))]}
+List {getList = [DeclNewtype (Newtype {newtypeName = "CM1", newtypeConstr = "MkCM1", newtypeField = "unCM1", newtypeType = HsPrimType HsPrimVoid}), DeclNewtype (Newtype {newtypeName = "CM2", newtypeConstr = "MkCM2", newtypeField = "unCM2", newtypeType = HsPrimType HsPrimVoid}), DeclNewtype (Newtype {newtypeName = "CT1", newtypeConstr = "MkCT1", newtypeField = "unCT1", newtypeType = HsPrimType HsPrimCInt}), DeclNewtype (Newtype {newtypeName = "CT2", newtypeConstr = "MkCT2", newtypeField = "unCT2", newtypeType = HsPrimType HsPrimCChar}), DeclData (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64, PeekByteOff x0 96]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (\(x1 ::: x2 ::: x3 ::: x4 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3, PokeByteOff x0 96 x4]}))))})))]}

hs-bindgen/fixtures/typedef_vs_macro.pp.hs

@@ -2,10 +2,19 @@
 
 module Example where
 
+import Data.Void (Void)
 import qualified Foreign as F
 import qualified Foreign.C as FC
 import Prelude ((<*>), (>>), pure)
 
+newtype CM1 = MkCM1
+  { unCM1 :: Void
+  }
+
+newtype CM2 = MkCM2
+  { unCM2 :: Void
+  }
+
 newtype CT1 = MkCT1
   { unCT1 :: FC.CInt
   }

hs-bindgen/fixtures/typedef_vs_macro.th.txt

@@ -1,3 +1,5 @@
+newtype CM1 = MkCM1 {unCM1 :: Void}
+newtype CM2 = MkCM2 {unCM2 :: Void}
 newtype CT1 = MkCT1 {unCT1 :: CInt}
 newtype CT2 = MkCT2 {unCT2 :: CChar}
 data CExampleStruct

hs-bindgen/src/HsBindgen/C/Tc/Macro.hs

@@ -15,6 +15,7 @@ module HsBindgen.C.Tc.Macro
   , Type(..), Kind(..)
   , TyCon(..), DataTyCon(..), ClassTyCon(..)
   , QuantTy(..)
+  , isPrimTy
 
     -- ** Macro typechecking monads
   , TcM, runTcM, TcGenM
@@ -1014,6 +1015,15 @@ pattern PrimTy = TyConAppTy (DataTyCon PrimTyTyCon) VNil
 pattern Empty :: Type Ty
 pattern Empty = TyConAppTy (DataTyCon EmptyTyCon) VNil
 
+isPrimTy :: forall n. Nat.SNatI n => (Vec n (Type Ty) -> QuantTyBody) -> Bool
+isPrimTy bf = case Nat.snat @n of
+    Nat.SZ -> isPrimTy' (bf VNil)
+    Nat.SS -> False
+
+isPrimTy' :: QuantTyBody -> Bool
+isPrimTy' (QuantTyBody [] PrimTy) = True
+isPrimTy' _                       = False
+
 {-------------------------------------------------------------------------------
   Typechecking macros: classes
 --------------------------------------------------------------------------------

hs-bindgen/src/HsBindgen/Translation/LowLevel.hs

@@ -15,14 +15,15 @@ import Data.Foldable
 import Data.Kind
 import Data.Maybe
 import Data.Type.Nat
-import Data.Vec.Lazy (Vec)
+import Data.Vec.Lazy (Vec (..))
 import Data.Vec.Lazy qualified as Vec
 
 import HsBindgen.C.AST qualified as C
 import HsBindgen.Hs.AST qualified as Hs
 import HsBindgen.Util.PHOAS
 import HsBindgen.Hs.AST.Name
 import HsBindgen.Hs.AST.Type
+import HsBindgen.C.Tc.Macro qualified as C
 
 {-------------------------------------------------------------------------------
   Top-level
@@ -48,7 +49,7 @@ instance ToHs C.Decl where
   toHs (C.DeclStruct struct) = reifyStructFields struct $ structDecs struct
   toHs (C.DeclEnum e)        = enumDecs e
   toHs (C.DeclTypedef d)     = typedefDecs d
-  toHs (C.DeclMacro _)       = List [] -- TODO
+  toHs (C.DeclMacro m)       = macroDecs m
 
 {-------------------------------------------------------------------------------
   Structs
@@ -185,6 +186,37 @@ typedefDecs d = List [
           newtypeType    = typ nm (C.typedefType d)
       in Hs.Newtype {..}
 
+{-------------------------------------------------------------------------------
+  Macros
+-------------------------------------------------------------------------------}
+
+macroDecs :: C.MacroDecl -> List Hs.Decl f
+macroDecs C.MacroDecl {..}
+    | Just (C.QuantTy bf) <- macroDeclMacroTy
+    , C.isPrimTy bf
+    = macroDecsTypedef macroDeclMacro
+
+    | otherwise = List []
+
+macroDecs C.MacroReparseError {} = List []
+macroDecs C.MacroTcError {}      = List []
+
+macroDecsTypedef :: C.Macro -> List Hs.Decl f
+macroDecsTypedef m = List [
+        Hs.DeclNewtype newtype_
+      ]
+  where
+    newtype_ :: Hs.Newtype
+    newtype_ =
+      let cName = C.macroName m
+          nm@NameMangler{..} = defaultNameMangler
+          typeConstrCtx = TypeConstrContext cName
+          newtypeName = mangleTypeConstrName typeConstrCtx
+          newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
+          newtypeField = mangleVarName $ EnumVarContext typeConstrCtx
+          newtypeType    = typ nm $ C.TypPrim C.PrimVoid --  TODO
+      in Hs.Newtype {..}
+
 {-------------------------------------------------------------------------------
   Types
 -------------------------------------------------------------------------------}