Skip to content

Commit

Permalink
Add AST annotations
Browse files Browse the repository at this point in the history
  • Loading branch information
@TravisCardwell
TravisCardwell committed Nov 13, 2024
1 parent fa2b3ae commit d759246
Show file tree
Hide file tree
Showing 6 changed files with 165 additions and 103 deletions.
69 changes: 37 additions & 32 deletions hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,31 +41,31 @@ 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)

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
Expand Down Expand Up @@ -95,27 +95,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 $
Expand All @@ -136,11 +141,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
Expand All @@ -150,7 +155,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

{-------------------------------------------------------------------------------
Internal auxiliary: derived functionality
Expand Down
4 changes: 3 additions & 1 deletion hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,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
Expand Down
131 changes: 89 additions & 42 deletions hs-bindgen/src/HsBindgen/Hs/AST.hs
View file
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 All @@ -44,37 +47,70 @@ module HsBindgen.Hs.AST (
, ElimStruct(..)
) where

import Data.Kind
import Data.Nat
import Data.Type.Nat
import Data.Vec.Lazy (Vec(..))
import Generics.SOP qualified as SOP
import GHC.Base (Symbol)
import GHC.Generics qualified as GHC
import GHC.Show (appPrec1)

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
Expand All @@ -97,11 +133,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)
deriving stock (GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
Expand All @@ -112,9 +148,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)

Expand All @@ -132,15 +168,15 @@ data DataDecl n f = MkDataDecl
-- 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)

Expand Down Expand Up @@ -174,19 +210,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)

Expand All @@ -196,14 +232,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 ShowOpen (a Unique) => ShowOpen (Seq a Unique)
Expand All @@ -213,22 +258,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
Expand Down
2 changes: 1 addition & 1 deletion hs-bindgen/src/HsBindgen/Lib.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

{-------------------------------------------------------------------------------
Expand Down
Loading

0 comments on commit d759246

Please sign in to comment.