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/Backend/Common/Translation.hs

@@ -7,6 +7,7 @@ import Data.Coerce
 import Data.Foldable
 import Data.Vec.Lazy (Vec(..))
 
+import HsBindgen.Annotations qualified as Ann
 import HsBindgen.Backend.Common
 import HsBindgen.C.AST qualified as C (MFun(..))
 import HsBindgen.C.Tc.Macro (DataTyCon(..), ClassTyCon(..))
@@ -46,32 +47,32 @@ instance (DefToBE be a, DefToBE be b) => ToBE be (Hs.Ap a b) where
   Declarations
 -------------------------------------------------------------------------------}
 
-instance Backend be => ToBE be Hs.Decl where
-  type Rep be Hs.Decl = Decl be
+instance Backend be => ToBE be (Hs.Decl Ann.HsPlaceholder) where
+  type Rep be (Hs.Decl Ann.HsPlaceholder) = Decl be
   toBE be (Hs.DeclData d) = mkDecl be <$> toBE be d
   toBE be (Hs.DeclNewtype n) = mkDecl be <$> return (newtypeToBE be n)
   toBE be (Hs.DeclInstance i) = inst be <$> toBE be i
   toBE be (Hs.DeclNewtypeInstance tc c) = mkDecl be <$> return (newtypeInstance be tc c)
   toBE be (Hs.DeclVar v) = var be v
 
-instance Backend be => ToBE be Hs.InstanceDecl where
-  type Rep be Hs.InstanceDecl = Instance be
+instance Backend be => ToBE be (Hs.InstanceDecl Ann.HsPlaceholder) where
+  type Rep be (Hs.InstanceDecl Ann.HsPlaceholder) = Instance be
   toBE be (Hs.InstanceStorable i) = toBE be i
 
-instance Backend be => ToBE be (Hs.WithStruct Hs.DataDecl) where
-  type Rep be (Hs.WithStruct Hs.DataDecl) = SDecl be
+instance Backend be => ToBE be (Hs.WithStruct Ann.HsPlaceholder Hs.DataDecl) where
+  type Rep be (Hs.WithStruct Ann.HsPlaceholder Hs.DataDecl) = SDecl be
 
   toBE _be (Hs.WithStruct struct Hs.MkDataDecl) = do
     return $ DRecord $ Record
       { dataType = Hs.structName struct
       , dataCon  = Hs.structConstr struct
       , dataFields =
           [ (n, typeToBE t)
-          | (n, t) <- toList $ Hs.structFields struct
+          | (_ann, (n, t)) <- toList $ Hs.structFields struct
           ]
       }
 
-newtypeToBE :: be -> Hs.Newtype -> SDecl be
+newtypeToBE :: be -> Hs.Newtype Ann.HsPlaceholder -> SDecl be
 newtypeToBE _ n =
   DNewtype $ Newtype
     { newtypeName  = Hs.newtypeName n
@@ -101,27 +102,32 @@ typeToBE (Hs.HsType _)         = TGlobal (PrimType HsPrimVoid)
   'Storable'
 -------------------------------------------------------------------------------}
 
-instance Backend be => ToBE be (Hs.WithStruct Hs.StorableInstance) where
-  type Rep be (Hs.WithStruct Hs.StorableInstance) = Instance be
-
-  toBE be (Hs.WithStruct struct Hs.StorableInstance{
-          storableSizeOf
-        , storableAlignment
-        , storablePeek
-        , storablePoke
-        }) = do
-      peek <- toBE be storablePeek
-      poke <- toBE be storablePoke
-      return $ Instance {
-          instanceClass = Storable_Storable
-        , instanceType  = Hs.structName struct
-        , instanceDecs  = [
-              (Storable_sizeOf    , ELam Nothing $ EInt storableSizeOf)
-            , (Storable_alignment , ELam Nothing $ EInt storableAlignment)
-            , (Storable_peek      , EInj peek)
-            , (Storable_poke      , EInj poke)
-            ]
-        }
+instance
+     Backend be
+  => ToBE be (Hs.WithStruct Ann.HsPlaceholder (Hs.StorableInstance Ann.HsPlaceholder))
+  where
+
+    type Rep be (Hs.WithStruct Ann.HsPlaceholder (Hs.StorableInstance Ann.HsPlaceholder)) =
+      Instance be
+
+    toBE be (Hs.WithStruct struct Hs.StorableInstance{
+            storableSizeOf
+          , storableAlignment
+          , storablePeek
+          , storablePoke
+          }) = do
+        peek <- toBE be storablePeek
+        poke <- toBE be storablePoke
+        return $ Instance {
+            instanceClass = Storable_Storable
+          , instanceType  = Hs.structName struct
+          , instanceDecs  = [
+                (Storable_sizeOf    , ELam Nothing $ EInt storableSizeOf)
+              , (Storable_alignment , ELam Nothing $ EInt storableAlignment)
+              , (Storable_peek      , EInj peek)
+              , (Storable_poke      , EInj poke)
+              ]
+          }
 
 instance Backend be => ToBE be Hs.PeekByteOff where
   toBE be (Hs.PeekByteOff ptr i) = return . mkExpr be $
@@ -142,11 +148,11 @@ instance DefToBE be a => ToBE be (Hs.Seq a) where
   Structs
 -------------------------------------------------------------------------------}
 
-instance Backend be => ToBE be (Hs.IntroStruct n) where
+instance Backend be => ToBE be (Hs.IntroStruct Ann.HsPlaceholder n) where
   toBE be (Hs.IntroStruct struct) = return $
       mkExpr be $ ECon $ Hs.structConstr struct
 
-instance DefToBE be a => ToBE be (Hs.ElimStruct n a) where
+instance DefToBE be a => ToBE be (Hs.ElimStruct Ann.HsPlaceholder n a) where
   toBE be (Hs.ElimStruct struct k) =
       fresh    be "x"        $ \x ->
       freshVec be fieldNames $ \fs -> do
@@ -156,7 +162,7 @@ instance DefToBE be a => ToBE be (Hs.ElimStruct n a) where
           ]
     where
       fieldNames :: Vec n (HsName NsVar)
-      fieldNames = fst <$> Hs.structFields struct
+      fieldNames = fst . snd <$> Hs.structFields struct
 
 {-------------------------------------------------------------------------------
   Variable declarations

hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs

@@ -6,6 +6,7 @@ module HsBindgen.Backend.TH.Translation (
 import Control.Monad (join)
 import Language.Haskell.TH qualified as TH
 
+import HsBindgen.Annotations qualified as Ann
 import HsBindgen.Backend.Common
 import HsBindgen.Backend.Common.Translation
 import HsBindgen.Backend.TH
@@ -20,7 +21,9 @@ import HsBindgen.Translation.LowLevel
 translateC :: TH.Quote q => C.Header -> q [TH.Dec]
 translateC = translateHs . generateDeclarations
 
-translateHs :: forall q. TH.Quote q => [Hs.Decl (Fresh (BE q))] -> q [TH.Dec]
+translateHs :: forall q. TH.Quote q
+  => [Hs.Decl Ann.HsPlaceholder (Fresh (BE q))]
+  -> q [TH.Dec]
 translateHs =
     aux . runM . mapM (toBE BE)
   where

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

@@ -54,39 +54,55 @@ module HsBindgen.Hs.AST (
   , ElimStruct(..)
   ) where
 
+import Data.Kind (Constraint)
 import Data.Nat
 import Data.Type.Nat
-import Data.Vec.Lazy (Vec(..), toList)
+import Data.Vec.Lazy (Vec(..))
 import Generics.SOP qualified as SOP
 import GHC.Generics qualified as GHC
 import GHC.Show (appPrec1)
 
+import HsBindgen.Annotations (Ann, AnnHsPlaceholder, Pass)
 import HsBindgen.C.AST qualified as C (MFun(..))
 import HsBindgen.C.Tc.Macro qualified as C
 import HsBindgen.Hs.AST.Name
 import HsBindgen.Hs.AST.Type
+import HsBindgen.Imports
 import HsBindgen.Util.PHOAS
 
 {-------------------------------------------------------------------------------
   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
+     (Show (Ann pass "Struct"), Show (Ann pass "StructField"))
+  => Show (Struct pass n)
 
-data Newtype = Newtype {
-      newtypeName   :: HsName NsTypeConstr
-    , newtypeConstr :: HsName NsConstr
-    , newtypeField  :: HsName NsVar
-    , newtypeType   :: HsType
+type instance AnnHsPlaceholder "Struct" = ()
+type instance AnnHsPlaceholder "StructField" = ()
+
+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
+     (Show (Ann pass "Newtype"), Show (Ann pass "NewtypeField"))
+  => Show (Newtype pass)
+
+type instance AnnHsPlaceholder "Newtype" = ()
+type instance AnnHsPlaceholder "NewtypeField" = ()
 
 {-------------------------------------------------------------------------------
   Variable binding
@@ -115,11 +131,11 @@ data Ap a b f = Ap (b f) [a f]
 -------------------------------------------------------------------------------}
 
 -- | Top-level declaration
-type Decl :: PHOAS
-data Decl f =
-    DeclData (WithStruct DataDecl f)
-  | DeclNewtype Newtype
-  | DeclInstance (InstanceDecl f)
+type Decl :: Pass -> PHOAS
+data Decl pass f =
+    DeclData (WithStruct pass DataDecl f)
+  | DeclNewtype (Newtype pass)
+  | DeclInstance (InstanceDecl pass f)
   | DeclNewtypeInstance TypeClass (HsName NsTypeConstr)
   | DeclVar (VarDecl f)
   deriving stock (GHC.Generic)
@@ -131,9 +147,9 @@ data TypeClass =
   deriving stock (Show)
 
 -- | Class instance declaration
-type InstanceDecl :: PHOAS
-data InstanceDecl f =
-    InstanceStorable (WithStruct StorableInstance f)
+type InstanceDecl :: Pass -> PHOAS
+data InstanceDecl pass f =
+    InstanceStorable (WithStruct pass (StorableInstance pass) f)
   deriving stock (GHC.Generic)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
@@ -219,15 +235,15 @@ data VarDeclRHSAppHead
 -- Currently this models storable instances for structs /only/.
 --
 -- <https://hackage.haskell.org/package/base/docs/Foreign-Storable.html#t:Storable>
-type StorableInstance :: Nat -> PHOAS
-data StorableInstance n f where
+type StorableInstance :: Pass -> Nat -> PHOAS
+data StorableInstance pass n f where
     StorableInstance ::
          { storableSizeOf    :: Int
          , storableAlignment :: Int
-         , storablePeek      :: Lambda (Ap PeekByteOff (IntroStruct n)) f
-         , storablePoke      :: Lambda (ElimStruct n (Seq PokeByteOff)) f
+         , storablePeek      :: Lambda (Ap PeekByteOff (IntroStruct pass n)) f
+         , storablePoke      :: Lambda (ElimStruct pass n (Seq PokeByteOff)) f
          }
-      -> StorableInstance n f
+      -> StorableInstance pass n f
   deriving stock (GHC.Generic)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
@@ -261,19 +277,19 @@ newtype Seq a f = Seq (List a f)
   Structs
 -------------------------------------------------------------------------------}
 
-type WithStruct :: (Nat -> PHOAS) -> PHOAS
-data WithStruct a f where
-  WithStruct :: SNatI n => Struct n -> a n f -> WithStruct a f
+type WithStruct :: Pass -> (Nat -> PHOAS) -> PHOAS
+data WithStruct pass a f where
+  WithStruct :: SNatI n => Struct pass n -> a n f -> WithStruct pass a f
 
 -- | Construct value of a struct
-type IntroStruct :: Nat -> PHOAS
-data IntroStruct n f = IntroStruct (Struct n)
+type IntroStruct :: Pass -> Nat -> PHOAS
+data IntroStruct pass n f = IntroStruct (Struct pass n)
   deriving stock (GHC.Generic)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
 -- | Lambda-case for a struct
-type ElimStruct :: Nat -> PHOAS -> PHOAS
-data ElimStruct n a f = ElimStruct (Struct n) (Vec n (f Bound) -> a f)
+type ElimStruct :: Pass -> Nat -> PHOAS -> PHOAS
+data ElimStruct pass n a f = ElimStruct (Struct pass n) (Vec n (f Bound) -> a f)
   deriving stock (GHC.Generic)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
@@ -283,14 +299,30 @@ data ElimStruct n a f = ElimStruct (Struct n) (Vec n (f Bound) -> a f)
   These generate valid Haskell code.
 -------------------------------------------------------------------------------}
 
-deriving anyclass instance ShowOpen (Decl Unique)
+type ForallAnn (c :: Star -> Constraint) pass = (
+    c (Ann pass "Newtype")
+  , c (Ann pass "NewtypeField")
+  , c (Ann pass "Struct")
+  , c (Ann pass "StructField")
+  )
+
+deriving anyclass instance ForallAnn Show pass => ShowOpen (Decl pass Unique)
 deriving anyclass instance SNatI n => ShowOpen (DataDecl n Unique)
-deriving anyclass instance ShowOpen (InstanceDecl Unique)
+
+deriving anyclass instance
+     ForallAnn Show pass
+  => ShowOpen (InstanceDecl pass Unique)
+
 deriving anyclass instance ShowOpen (PeekByteOff Unique)
 deriving anyclass instance ShowOpen (PokeByteOff Unique)
 
-deriving anyclass instance SNatI n => ShowOpen (IntroStruct n Unique)
-deriving anyclass instance SNatI n => ShowOpen (StorableInstance n Unique)
+deriving anyclass instance
+     (ForallAnn Show pass, SNatI n)
+  => ShowOpen (IntroStruct pass n Unique)
+
+deriving anyclass instance
+     (ForallAnn Show pass, SNatI n)
+  => ShowOpen (StorableInstance pass n Unique)
 
 deriving anyclass instance ShowOpen (a Unique) => ShowOpen (Lambda a Unique)
 deriving anyclass instance (SNatI n, ShowOpen (a Unique)) => ShowOpen (Forall n a Unique)
@@ -301,22 +333,24 @@ deriving anyclass instance
   => ShowOpen (Ap a b Unique)
 
 deriving anyclass instance
-     (ShowOpen (a Unique), SNatI n)
-  => ShowOpen (ElimStruct n a Unique)
+     (ForallAnn Show pass, ShowOpen (a Unique), SNatI n)
+  => ShowOpen (ElimStruct pass n a Unique)
 
-deriving via Degenerate (Struct n) instance ShowOpen (Struct n)
+deriving via Degenerate (Struct pass n) instance
+     ForallAnn Show pass
+  => ShowOpen (Struct pass n)
 
 -- Handwritten instance (generics don't play nice with existentials)
 instance
-       (forall n. SNatI n => ShowOpen (a n Unique))
-    => ShowOpen (WithStruct a Unique) where
+       (ForallAnn Show pass, forall n. SNatI n => ShowOpen (a n Unique))
+    => ShowOpen (WithStruct pass a Unique) where
   showOpen u p (WithStruct struct a) = showParen (p >= appPrec1) $
         showString "WithStruct "
       . showOpen u appPrec1 struct
       . showString " "
       . showOpen u appPrec1 a
 
-instance ShowOpen Newtype where
+instance ForallAnn Show pass => ShowOpen (Newtype pass) where
     showOpen _ = showsPrec
 
 instance ShowOpen TypeClass where

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(..))
@@ -173,7 +174,7 @@ genModule opts = WrapHsModule . Backend.PP.translate opts . unwrapCHeader
 genTH :: TH.Quote q => CHeader -> q [TH.Dec]
 genTH = Backend.TH.translateC . unwrapCHeader
 
-genHsDecls :: CHeader -> List Hs.Decl f
+genHsDecls :: CHeader -> List (Hs.Decl Ann.HsPlaceholder) f
 genHsDecls = List . LowLevel.generateDeclarations . unwrapCHeader
 
 {-------------------------------------------------------------------------------