Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add AST annotations #276

Draft
wants to merge 1 commit into
base: main
Choose a base branch
from
Draft

Add AST annotations #276

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
139 changes: 97 additions & 42 deletions hs-bindgen/src/HsBindgen/Hs/AST.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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(..)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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'
--
Expand Down Expand Up @@ -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)
46 changes: 27 additions & 19 deletions hs-bindgen/src/HsBindgen/Hs/Translation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

{-------------------------------------------------------------------------------
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
]
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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 }
| Macro.QuantTy bf <- ty
, Macro.isPrimTy bf
Expand All @@ -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.
Expand Down Expand Up @@ -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 $
Expand Down
Loading
Loading