Implement Haskell AST annotations (demo)

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(..)
@@ -52,37 +55,65 @@ module HsBindgen.Hs.AST (
   , makeElimStruct
   ) where
 
-import HsBindgen.C.AST qualified as C (MFun(..))
-import HsBindgen.C.Tc.Macro qualified as C
 import Data.Type.Nat as Nat
+import GHC.Base (Symbol)
 
+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
 import HsBindgen.Hs.AST.Type
 
 import DeBruijn
 
+{-------------------------------------------------------------------------------
+  Passes and annotations
+-------------------------------------------------------------------------------}
+
+-- | Passes for the Haskell AST phase
+data Pass = Placeholder
+
+-- | Symbol-indexed annotations for a given pass
+type family Ann (pass :: Pass) (s :: Symbol) where
+  Ann Placeholder s = AnnPlaceholder s
+
+-- | Symbol-indexed annotations for the 'Placeholder' pass
+type family AnnPlaceholder (s :: Symbol) where
+  AnnPlaceholder s = ()
+
+-- Class alias to work around GHC limitation that type family synonym
+-- applications cannot be used in quantified constraints
+class    Show (Ann pass s) => ShowAnn pass s
+instance Show (Ann pass s) => ShowAnn pass s
+
+-- All annotations must have a 'Show' instance (quantified constraint)
+class    (forall s. ShowAnn pass s) => AllAnnShow pass
+instance (forall s. ShowAnn pass s) => AllAnnShow pass
+
 {-------------------------------------------------------------------------------
   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 AllAnnShow pass => Show (Struct pass n)
 
-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 AllAnnShow pass => Show (Newtype pass)
 
 {-------------------------------------------------------------------------------
   Variable binding
@@ -106,28 +137,31 @@ 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
-    DeclEmpty           :: HsName NsTypeConstr -> 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
+    DeclEmpty           :: HsName NsTypeConstr -> 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 AllAnnShow 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 AllAnnShow pass => Show (InstanceDecl pass)
 
 -- | Variable or function declaration.
 type VarDecl :: Star
@@ -214,15 +248,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 AllAnnShow pass => Show (StorableInstance pass)
 
 -- | Call to 'peekByteOff'
 --
@@ -252,28 +287,48 @@ 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 AllAnnShow 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
+     (AllAnnShow 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)

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

@@ -33,7 +33,7 @@ import DeBruijn (Idx (..), pattern I1, weaken, Add (..), pattern I2, EmptyCtx, S
   Top-level
 -------------------------------------------------------------------------------}
 
-generateDeclarations :: C.Header -> [Hs.Decl]
+generateDeclarations :: C.Header -> [Hs.Decl Hs.Placeholder]
 generateDeclarations = toHs
 
 {-------------------------------------------------------------------------------
@@ -45,11 +45,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 Hs.Placeholder]
   toHs (C.Header decs) = concatMap toHs decs
 
 instance ToHs C.Decl where
-  type InHs C.Decl = [Hs.Decl]
+  type InHs C.Decl = [Hs.Decl Hs.Placeholder]
   toHs (C.DeclStruct struct)  = reifyStructFields struct $ structDecs struct
   toHs (C.DeclOpaqueStruct n) = opaqueStructDecs n
   toHs (C.DeclEnum e)         = enumDecs e
@@ -79,27 +79,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 Hs.Placeholder]
 structDecs struct fields =
     [ Hs.DeclData hs
     , Hs.DeclInstance $ Hs.InstanceStorable hs storable
     ]
   where
-    hs :: Hs.Struct n
+    hs :: Hs.Struct Hs.Placeholder 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 Hs.Placeholder
     storable = Hs.StorableInstance {
           Hs.storableSizeOf    = C.structSizeof struct
         , Hs.storableAlignment = C.structAlignment struct
@@ -119,7 +120,7 @@ structDecs struct fields =
   Opaque struct
 -------------------------------------------------------------------------------}
 
-opaqueStructDecs :: C.CName -> [Hs.Decl]
+opaqueStructDecs :: C.CName -> [Hs.Decl Hs.Placeholder]
 opaqueStructDecs cname =
     [ Hs.DeclEmpty hsName
     ]
@@ -132,37 +133,40 @@ opaqueStructDecs cname =
   Enum
 -------------------------------------------------------------------------------}
 
-enumDecs :: C.Enu -> [Hs.Decl]
+enumDecs :: C.Enu -> [Hs.Decl Hs.Placeholder]
 enumDecs e = [
       Hs.DeclNewtype newtype_
     , Hs.DeclInstance $ Hs.InstanceStorable hs storable
     ]
   where
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Hs.Placeholder
     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 Hs.Placeholder (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 Hs.Placeholder
     storable = Hs.StorableInstance {
           Hs.storableSizeOf    = C.enumSizeof e
         , Hs.storableAlignment = C.enumAlignment e
@@ -182,7 +186,7 @@ enumDecs e = [
   Typedef
 -------------------------------------------------------------------------------}
 
-typedefDecs :: C.Typedef -> [Hs.Decl]
+typedefDecs :: C.Typedef -> [Hs.Decl Hs.Placeholder]
 typedefDecs d = [
       Hs.DeclNewtype newtype_
     , Hs.DeclNewtypeInstance Hs.Storable newtypeName
@@ -191,9 +195,11 @@ typedefDecs d = [
     cName              = C.typedefName d
     nm@NameMangler{..} = defaultNameMangler
     typeConstrCtx      = TypeConstrContext cName
+    newtypeAnn         = ()
     newtypeName        = mangleTypeConstrName typeConstrCtx
+    newtypeFieldAnn    = ()
 
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Hs.Placeholder
     newtype_ = Hs.Newtype {..}
       where
         newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx
@@ -204,7 +210,7 @@ typedefDecs d = [
   Macros
 -------------------------------------------------------------------------------}
 
-macroDecs :: C.MacroDecl -> [Hs.Decl]
+macroDecs :: C.MacroDecl -> [Hs.Decl Hs.Placeholder]
 macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
     | C.QuantTy bf <- ty
     , C.isPrimTy bf
@@ -217,18 +223,20 @@ macroDecs C.MacroDecl { macroDeclMacro = m, macroDeclMacroTy = ty }
 macroDecs C.MacroReparseError {} = []
 macroDecs C.MacroTcError {}      = []
 
-macroDecsTypedef :: C.Macro -> [Hs.Decl]
+macroDecsTypedef :: C.Macro -> [Hs.Decl Hs.Placeholder]
 macroDecsTypedef m = [
         Hs.DeclNewtype newtype_
       ]
   where
-    newtype_ :: Hs.Newtype
+    newtype_ :: Hs.Newtype Hs.Placeholder
     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.
@@ -277,7 +285,7 @@ floatingType = \case
   Macro
 -------------------------------------------------------------------------------}
 
-macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl]
+macroVarDecs :: C.Macro -> C.QuantTy -> [Hs.Decl Hs.Placeholder]
 macroVarDecs (C.Macro { macroName = cVarNm, macroArgs = args, macroBody = body } ) qty =
   [
     Hs.DeclVar $