Implement HsPlaceholder annotations (demo)

This implements `HsPlaceholder` annotations for the following, all with
unit annotations.

* `Newtype`
* `NewtypeField`
* `Struct`
* `StructField`

Note that the test fixtures are *not* updated to include annotations, so
many tests fail.  Since this commit is a demonstration that should not
be merged, failing tests are desirable.

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

@@ -52,10 +52,12 @@ module HsBindgen.Hs.AST (
   , makeElimStruct
   ) where
 
-import HsBindgen.C.AST qualified as C (MFun(..))
-import HsBindgen.C.Tc.Macro qualified as C
+import Data.Kind (Constraint)
 import Data.Type.Nat as Nat
 
+import HsBindgen.Annotations (Ann, AnnHsPlaceholder, Pass)
+import HsBindgen.C.AST qualified as C (MFun(..))
+import HsBindgen.C.Tc.Macro qualified as C
 import HsBindgen.Imports
 import HsBindgen.NameHint
 import HsBindgen.Hs.AST.Name
@@ -67,22 +69,31 @@ import DeBruijn
   Information about generated code
 -------------------------------------------------------------------------------}
 
-data Struct (n :: Nat) = Struct {
-      structName   :: HsName NsTypeConstr
+data Struct (pass :: Pass) (n :: Nat) = Struct {
+      structAnn    :: Ann pass "Struct"
+    , structName   :: HsName NsTypeConstr
     , structConstr :: HsName NsConstr
-    , structFields :: Vec n (HsName NsVar, HsType)
+    , structFields :: Vec n (Ann pass "StructField", (HsName NsVar, HsType))
     }
 
-deriving stock instance Show (Struct n)
+deriving stock instance ForallAnn Show pass => Show (Struct pass n)
+
+type instance AnnHsPlaceholder "Struct" = ()
+type instance AnnHsPlaceholder "StructField" = ()
 
-data Newtype = Newtype {
-      newtypeName   :: HsName NsTypeConstr
-    , newtypeConstr :: HsName NsConstr
-    , newtypeField  :: HsName NsVar
-    , newtypeType   :: HsType
+data Newtype (pass :: Pass) = Newtype {
+      newtypeAnn      :: Ann pass "Newtype"
+    , newtypeName     :: HsName NsTypeConstr
+    , newtypeConstr   :: HsName NsConstr
+    , newtypeFieldAnn :: Ann pass "NewtypeField"
+    , newtypeField    :: HsName NsVar
+    , newtypeType     :: HsType
     }
 
-deriving stock instance Show Newtype
+deriving stock instance ForallAnn Show pass => Show (Newtype pass)
+
+type instance AnnHsPlaceholder "Newtype" = ()
+type instance AnnHsPlaceholder "NewtypeField" = ()
 
 {-------------------------------------------------------------------------------
   Variable binding
@@ -106,27 +117,30 @@ data Ap pure xs ctx = Ap (pure ctx) [xs ctx]
 -------------------------------------------------------------------------------}
 
 -- | Top-level declaration
-type Decl :: Star
-data Decl where
-    DeclData            :: SNatI n => Struct n -> Decl
-    DeclNewtype         :: Newtype -> Decl
-    DeclInstance        :: InstanceDecl -> Decl
-    DeclNewtypeInstance :: TypeClass -> HsName NsTypeConstr -> Decl
-    DeclVar             :: VarDecl -> Decl
+type Decl :: Pass -> Star
+data Decl pass where
+    DeclData            :: SNatI n => Struct pass n -> Decl pass
+    DeclNewtype         :: Newtype pass -> Decl pass
+    DeclInstance        :: InstanceDecl pass -> Decl pass
+    DeclNewtypeInstance :: TypeClass -> HsName NsTypeConstr -> Decl pass
+    DeclVar             :: VarDecl -> Decl pass
 
-deriving instance Show Decl
+deriving instance ForallAnn Show pass => Show (Decl pass)
 
 -- | Class instance names
 data TypeClass =
     Storable
   deriving stock (Show)
 
 -- | Class instance declaration
-type InstanceDecl :: Star
-data InstanceDecl where
-    InstanceStorable :: Struct n -> StorableInstance -> InstanceDecl
+type InstanceDecl :: Pass -> Star
+data InstanceDecl pass where
+    InstanceStorable ::
+         Struct pass n
+      -> StorableInstance pass
+      -> InstanceDecl pass
 
-deriving instance Show InstanceDecl
+deriving instance ForallAnn Show pass => Show (InstanceDecl pass)
 
 -- | Variable or function declaration.
 type VarDecl :: Star
@@ -213,15 +227,16 @@ deriving stock instance Show VarDeclRHSAppHead
 -- Currently this models storable instances for structs /only/.
 --
 -- <https://hackage.haskell.org/package/base/docs/Foreign-Storable.html#t:Storable>
-type StorableInstance :: Star
-data StorableInstance = StorableInstance
+type StorableInstance :: Pass -> Star
+data StorableInstance pass = StorableInstance
     { storableSizeOf    :: Int
     , storableAlignment :: Int
-    , storablePeek      :: Lambda (Ap StructCon PeekByteOff) EmptyCtx
-    , storablePoke      :: Lambda (Lambda (ElimStruct (Seq PokeByteOff))) EmptyCtx
+    , storablePeek      :: Lambda (Ap (StructCon pass) PeekByteOff) EmptyCtx
+    , storablePoke      ::
+        Lambda (Lambda (ElimStruct pass (Seq PokeByteOff))) EmptyCtx
     }
 
-deriving instance Show StorableInstance
+deriving instance ForallAnn Show pass => Show (StorableInstance pass)
 
 -- | Call to 'peekByteOff'
 --
@@ -251,28 +266,59 @@ newtype Seq t ctx = Seq [t ctx]
   Structs
 -------------------------------------------------------------------------------}
 
-type StructCon :: Ctx -> Star
-data StructCon ctx where
-    StructCon :: Struct n -> StructCon ctx
+type StructCon :: Pass -> Ctx -> Star
+data StructCon pass ctx where
+    StructCon :: Struct pass n -> StructCon pass ctx
 
-deriving instance Show (StructCon ctx)
+deriving instance ForallAnn Show pass => Show (StructCon pass ctx)
 
 -- | Case split for a struct
-type ElimStruct :: (Ctx -> Star) -> (Ctx -> Star)
-data ElimStruct t ctx where
-    ElimStruct :: Idx ctx -> Struct n -> Add n ctx ctx' -> t ctx' -> ElimStruct t ctx
-
-deriving instance (forall ctx'. Show (t ctx')) => Show (ElimStruct t ctx)
+type ElimStruct :: Pass -> (Ctx -> Star) -> (Ctx -> Star)
+data ElimStruct pass t ctx where
+    ElimStruct ::
+         Idx ctx
+      -> Struct pass n
+      -> Add n ctx ctx'
+      -> t ctx'
+      -> ElimStruct pass t ctx
+
+deriving instance
+     (ForallAnn Show pass, forall ctx'. Show (t ctx'))
+  => Show (ElimStruct pass t ctx)
 
 -- | Create 'ElimStruct' using kind-of HOAS interface.
 --
-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
+makeElimStruct :: forall n ctx t pass.
+     SNatI n
+  => Idx ctx
+  -> Struct pass n
+  -> (forall ctx'. Wk ctx ctx' -> Vec n (Idx ctx') -> t ctx')
+  -> ElimStruct pass t ctx
 makeElimStruct s struct kont = makeElimStruct' (snat :: SNat n) $ \add wk xs ->
     ElimStruct s struct add (kont wk xs)
 
 --
 -- TODO: use Data.Type.Nat.induction instead of explicit recursion.
 -- TODO: verify that we bind fields in right order.
-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
+makeElimStruct' :: forall m ctx t pass.
+     SNat m
+  -> ( forall ctx'.
+            Add m ctx ctx'
+         -> Wk ctx ctx'
+         -> Vec m (Idx ctx')
+         -> ElimStruct pass t ctx
+     )
+  -> ElimStruct pass t ctx
 makeElimStruct' Nat.SZ      kont = kont AZ IdWk VNil
 makeElimStruct' (Nat.SS' n) kont = makeElimStruct' n $ \add wk xs -> kont (AS add) (SkipWk wk) (IZ ::: fmap IS xs)
+
+{-------------------------------------------------------------------------------
+  Auxilliary
+-------------------------------------------------------------------------------}
+
+type ForallAnn (c :: Star -> Constraint) pass = (
+    c (Ann pass "Newtype")
+  , c (Ann pass "NewtypeField")
+  , c (Ann pass "Struct")
+  , c (Ann pass "StructField")
+  )

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

@@ -22,6 +22,7 @@ import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import Data.Vec.Lazy qualified as Vec
 
+import HsBindgen.Annotations qualified as Ann
 import HsBindgen.Imports
 import HsBindgen.NameHint
 import HsBindgen.C.AST qualified as C
@@ -36,7 +37,7 @@ import DeBruijn (Idx (..), pattern I1, weaken, Add (..), pattern I2, EmptyCtx, S
   Top-level
 -------------------------------------------------------------------------------}
 
-generateDeclarations :: C.Header -> [Hs.Decl]
+generateDeclarations :: C.Header -> [Hs.Decl Ann.HsPlaceholder]
 generateDeclarations = toHs
 
 {-------------------------------------------------------------------------------
@@ -48,11 +49,11 @@ class ToHs (a :: Star) where
   toHs :: a -> InHs a
 
 instance ToHs C.Header where
-  type InHs C.Header = [Hs.Decl]
+  type InHs C.Header = [Hs.Decl Ann.HsPlaceholder]
   toHs (C.Header decs) = concatMap toHs decs
 
 instance ToHs C.Decl where
-  type InHs C.Decl = [Hs.Decl]
+  type InHs C.Decl = [Hs.Decl Ann.HsPlaceholder]
   toHs (C.DeclStruct struct) = reifyStructFields struct $ structDecs struct
   toHs (C.DeclEnum e)        = enumDecs e
   toHs (C.DeclTypedef d)     = typedefDecs d
@@ -81,27 +82,28 @@ reifyStructFields struct k = Vec.reifyList (C.structFields struct) k
 -- * ..
 structDecs :: forall n.
      SNatI n
-  => C.Struct -> Vec n C.StructField -> [Hs.Decl]
+  => C.Struct -> Vec n C.StructField -> [Hs.Decl Ann.HsPlaceholder]
 structDecs struct fields =
     [ Hs.DeclData hs
     , Hs.DeclInstance $ Hs.InstanceStorable hs storable
     ]
   where
-    hs :: Hs.Struct n
+    hs :: Hs.Struct Ann.HsPlaceholder n
     hs =
       let cStructName = fromMaybe "X" $ C.structTag struct
           nm@NameMangler{..} = defaultNameMangler
           typeConstrCtx = TypeConstrContext cStructName
+          structAnn = ()
           structName = mangleTypeConstrName typeConstrCtx
           structConstr = mangleConstrName $ ConstrContext typeConstrCtx
-          mkField f =
+          mkField f = (,) () $
             ( mangleVarName $ FieldVarContext typeConstrCtx True (C.fieldName f)
             , typ nm (C.fieldType f)
             )
           structFields = Vec.map mkField fields
       in  Hs.Struct{..}
 
-    storable :: Hs.StorableInstance
+    storable :: Hs.StorableInstance Ann.HsPlaceholder
     storable = Hs.StorableInstance {
           Hs.storableSizeOf    = C.structSizeof struct
         , Hs.storableAlignment = C.structAlignment struct
@@ -121,37 +123,40 @@ structDecs struct fields =
   Enum
 -------------------------------------------------------------------------------}
 
-enumDecs :: C.Enu -> [Hs.Decl]
+enumDecs :: C.Enu -> [Hs.Decl Ann.HsPlaceholder]
 enumDecs e = [
       Hs.DeclNewtype newtype_
     , Hs.DeclInstance $ Hs.InstanceStorable hs storable
     ]
   where
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Ann.HsPlaceholder
     newtype_ =
       let cEnumName = fromMaybe "X" $ C.enumTag e
           nm@NameMangler{..} = defaultNameMangler
           typeConstrCtx = TypeConstrContext cEnumName
+          newtypeAnn = ()
           newtypeName = mangleTypeConstrName typeConstrCtx
           newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
+          newtypeFieldAnn = ()
           newtypeField = mangleVarName $ EnumVarContext typeConstrCtx
           newtypeType    = typ nm (C.enumType e)
       in Hs.Newtype {..}
 
-    hs :: Hs.Struct (S Z)
+    hs :: Hs.Struct Ann.HsPlaceholder (S Z)
     hs =
       let cEnumName = fromMaybe "X" $ C.enumTag e
           nm@NameMangler{..} = defaultNameMangler
           typeConstrCtx = TypeConstrContext cEnumName
+          structAnn = ()
           structName = mangleTypeConstrName typeConstrCtx
           structConstr = mangleConstrName $ ConstrContext typeConstrCtx
-          structFields = Vec.singleton
+          structFields = Vec.singleton . (,) () $
             ( mangleVarName $ EnumVarContext typeConstrCtx
             , typ nm (C.enumType e)
             )
       in  Hs.Struct{..}
 
-    storable :: Hs.StorableInstance
+    storable :: Hs.StorableInstance Ann.HsPlaceholder
     storable = Hs.StorableInstance {
           Hs.storableSizeOf    = C.enumSizeof e
         , Hs.storableAlignment = C.enumAlignment e
@@ -171,7 +176,7 @@ enumDecs e = [
   Typedef
 -------------------------------------------------------------------------------}
 
-typedefDecs :: C.Typedef -> [Hs.Decl]
+typedefDecs :: C.Typedef -> [Hs.Decl Ann.HsPlaceholder]
 typedefDecs d = [
       Hs.DeclNewtype newtype_
     , Hs.DeclNewtypeInstance Hs.Storable newtypeName
@@ -180,9 +185,11 @@ typedefDecs d = [
     cName              = C.typedefName d
     nm@NameMangler{..} = defaultNameMangler
     typeConstrCtx      = TypeConstrContext cName
+    newtypeAnn         = ()
     newtypeName        = mangleTypeConstrName typeConstrCtx
+    newtypeFieldAnn    = ()
 
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Ann.HsPlaceholder
     newtype_ = Hs.Newtype {..}
       where
         newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
@@ -193,7 +200,7 @@ typedefDecs d = [
   Macros
 -------------------------------------------------------------------------------}
 
-macroDecs :: C.MacroDecl -> [Hs.Decl]
+macroDecs :: C.MacroDecl -> [Hs.Decl Ann.HsPlaceholder]
 macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
     | C.QuantTy bf <- ty
     , C.isPrimTy bf
@@ -206,18 +213,20 @@ macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
 macroDecs C.MacroReparseError {} = []
 macroDecs C.MacroTcError {}      = []
 
-macroDecsTypedef :: C.Macro -> [Hs.Decl]
+macroDecsTypedef :: C.Macro -> [Hs.Decl Ann.HsPlaceholder]
 macroDecsTypedef m = [
         Hs.DeclNewtype newtype_
       ]
   where
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Ann.HsPlaceholder
     newtype_ =
       let cName = C.macroName m
           nm@NameMangler{..} = defaultNameMangler
           typeConstrCtx = TypeConstrContext cName
+          newtypeAnn = ()
           newtypeName = mangleTypeConstrName typeConstrCtx
           newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
+          newtypeFieldAnn = ()
           newtypeField = mangleVarName $ EnumVarContext typeConstrCtx
 
           -- TODO: this type conversion is very simple, but works for now.
@@ -266,7 +275,7 @@ floatingType = \case
   Macro
 -------------------------------------------------------------------------------}
 
-macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl]
+macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl Ann.HsPlaceholder]
 macroVarDecs (C.Macro { macroName = cVarNm, macroArgs = args, macroBody = body } ) qty =
   [
     Hs.DeclVar $

hs-bindgen/src/HsBindgen/Lib.hs

@@ -73,6 +73,7 @@ import GHC.Generics (Generic)
 import Language.Haskell.TH qualified as TH
 import Text.Show.Pretty qualified as Pretty
 
+import HsBindgen.Annotations qualified as Ann
 import HsBindgen.Backend.PP.Render (HsRenderOpts(..))
 import HsBindgen.Backend.PP.Render qualified as Backend.PP
 import HsBindgen.Backend.PP.Translation (HsModuleOpts(..))
@@ -172,7 +173,7 @@ genModule opts = WrapHsModule . Backend.PP.translate opts . unwrapCHeader
 genTH :: TH.Quote q => CHeader -> q [TH.Dec]
 genTH = Backend.TH.translateC . unwrapCHeader
 
-genHsDecls :: CHeader -> [Hs.Decl]
+genHsDecls :: CHeader -> [Hs.Decl Ann.HsPlaceholder]
 genHsDecls = LowLevel.generateDeclarations . unwrapCHeader
 
 {-------------------------------------------------------------------------------