Add AST annotations

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

@@ -46,32 +46,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 Hs.Parsed) where
+  type Rep be (Hs.Decl Hs.Parsed) = 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 Hs.Parsed) where
+  type Rep be (Hs.InstanceDecl Hs.Parsed) = 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 Hs.Parsed Hs.DataDecl) where
+  type Rep be (Hs.WithStruct Hs.Parsed 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 Hs.Parsed -> SDecl be
 newtypeToBE _ n =
   DNewtype $ Newtype
     { newtypeName  = Hs.newtypeName n
@@ -101,27 +101,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 Hs.Parsed (Hs.StorableInstance Hs.Parsed))
+  where
+
+    type Rep be (Hs.WithStruct Hs.Parsed (Hs.StorableInstance Hs.Parsed)) =
+      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 +147,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 Hs.Parsed 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 Hs.Parsed n a) where
   toBE be (Hs.ElimStruct struct k) =
       fresh    be "x"        $ \x ->
       freshVec be fieldNames $ \fs -> do
@@ -156,7 +161,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

@@ -20,7 +20,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 Hs.Parsed (Fresh (BE q))]
+  -> q [TH.Dec]
 translateHs =
     aux . runM . mapM (toBE BE)
   where

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

@@ -18,8 +18,11 @@
 --
 -- > import HsBindgen.Hs.AST qualified as Hs
 module HsBindgen.Hs.AST (
+    -- * Passes and annotations
+    Pass(..)
+  , Ann
     -- * Information about generated code
-    Struct(..)
+  , Struct(..)
   , Newtype(..)
     -- * Types
   , HsType(..)
@@ -54,10 +57,12 @@ module HsBindgen.Hs.AST (
   , ElimStruct(..)
   ) where
 
+import Data.Kind
 import Data.Nat
 import Data.Type.Nat
 import Data.Vec.Lazy (Vec(..), toList)
 import Generics.SOP qualified as SOP
+import GHC.Base (Symbol)
 import GHC.Generics qualified as GHC
 import GHC.Show (appPrec1)
 
@@ -67,26 +72,57 @@ import HsBindgen.Hs.AST.Name
 import HsBindgen.Hs.AST.Type
 import HsBindgen.Util.PHOAS
 
+{-------------------------------------------------------------------------------
+  Passes and Annotations
+-------------------------------------------------------------------------------}
+
+data Pass = Parsed
+
+type Ann :: Symbol -> Pass -> Type
+type family Ann con pass
+
+type ForallAnn (c :: Type -> Constraint) pass =
+  ( c (Ann "Newtype" pass)
+  , c (Ann "NewtypeField" pass)
+  , c (Ann "Struct" pass)
+  , c (Ann "StructField" pass)
+  )
+
 {-------------------------------------------------------------------------------
   Information about generated code
 -------------------------------------------------------------------------------}
 
-data Struct (n :: Nat) = Struct {
-      structName   :: HsName NsTypeConstr
+type Struct :: Pass -> Nat -> Type
+data Struct pass n = Struct {
+      structAnn    :: Ann "Struct" pass
+    , structName   :: HsName NsTypeConstr
     , structConstr :: HsName NsConstr
-    , structFields :: Vec n (HsName NsVar, HsType)
+    , structFields :: Vec n (Ann "StructField" pass, (HsName NsVar, HsType))
     }
 
-deriving stock instance Show (Struct n)
-
-data Newtype = Newtype {
-      newtypeName   :: HsName NsTypeConstr
-    , newtypeConstr :: HsName NsConstr
-    , newtypeField  :: HsName NsVar
-    , newtypeType   :: HsType
+deriving stock instance
+     (Show (Ann "Struct" pass), Show (Ann "StructField" pass))
+  => Show (Struct pass n)
+
+type instance Ann "Struct" Parsed = ()
+type instance Ann "StructField" Parsed = ()
+
+type Newtype :: Pass -> Type
+data Newtype pass = Newtype {
+      newtypeAnn      :: Ann "Newtype" pass
+    , newtypeName     :: HsName NsTypeConstr
+    , newtypeConstr   :: HsName NsConstr
+    , newtypeFieldAnn :: Ann "NewtypeField" pass
+    , newtypeField    :: HsName NsVar
+    , newtypeType     :: HsType
     }
 
-deriving stock instance Show Newtype
+deriving stock instance
+     (Show (Ann "Newtype" pass), Show (Ann "NewtypeField" pass))
+  => Show (Newtype pass)
+
+type instance Ann "Newtype" Parsed = ()
+type instance Ann "NewtypeField" Parsed = ()
 
 {-------------------------------------------------------------------------------
   Variable binding
@@ -115,11 +151,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 +167,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 +255,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 +297,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 +319,23 @@ 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)
+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 +346,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

@@ -173,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 -> List Hs.Decl f
+genHsDecls :: CHeader -> List (Hs.Decl Hs.Parsed) f
 genHsDecls = List . LowLevel.generateDeclarations . unwrapCHeader
 
 {-------------------------------------------------------------------------------