Skip to content

Commit

Permalink
Add pointer types
Browse files Browse the repository at this point in the history
  • Loading branch information
@phadej @edsko
phadej authored and edsko committed Oct 30, 2024
1 parent cf42c49 commit 7733235
Show file tree
Hide file tree
Showing 9 changed files with 25 additions and 12 deletions.
1 change: 1 addition & 0 deletions hs-bindgen/examples/simple_structs.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,4 +19,5 @@ typedef struct {
struct S4 {
char b;
int a;
int *c;
};
2 changes: 1 addition & 1 deletion hs-bindgen/fixtures/simple_structs.hs
View file
Original file line number Diff line number Diff line change
@@ -1 +1 @@
List {getList = [DeclData (WithStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclData (WithStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (StorableInstance {storableSizeOf = 12, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (\(x1 ::: x2 ::: x3 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3]}))))}))), DeclData (WithStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 1, storableAlignment = 1, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1]}))))}))), DeclData (WithStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))})))]}
List {getList = [DeclData (WithStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS1", structConstr = "MkCS1", structFields = ("cS1_a",HsPrimType HsPrimCInt) ::: ("cS1_b",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclData (WithStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (StorableInstance {storableSizeOf = 12, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS2", structConstr = "MkCS2", structFields = ("cS2_a",HsPrimType HsPrimCChar) ::: ("cS2_b",HsPrimType HsPrimCInt) ::: ("cS2_c",HsPrimType HsPrimCFloat) ::: VNil}) (\(x1 ::: x2 ::: x3 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3]}))))}))), DeclData (WithStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 1, storableAlignment = 1, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CX", structConstr = "MkCX", structFields = ("cX_a",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1]}))))}))), DeclData (WithStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: ("cS4_c",HsPtr (HsPrimType HsPrimCInt)) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: ("cS4_c",HsPtr (HsPrimType HsPrimCInt)) ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 8, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: ("cS4_c",HsPtr (HsPrimType HsPrimCInt)) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CS4", structConstr = "MkCS4", structFields = ("cS4_b",HsPrimType HsPrimCChar) ::: ("cS4_a",HsPrimType HsPrimCInt) ::: ("cS4_c",HsPtr (HsPrimType HsPrimCInt)) ::: VNil}) (\(x1 ::: x2 ::: x3 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3]}))))})))]}
12 changes: 7 additions & 5 deletions hs-bindgen/fixtures/simple_structs.th.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,11 +22,13 @@ instance Storable CX
peek = \x_0 -> pure MkCX <*> peekByteOff x_0 0;
poke = \x_1 -> \x_2 -> case x_2 of
{MkCX cX_a_3 -> pokeByteOff x_1 0 cX_a_3}}
data CS4 = MkCS4 {cS4_b :: CChar, cS4_a :: CInt}
data CS4
= MkCS4 {cS4_b :: CChar, cS4_a :: CInt, cS4_c :: (Ptr CInt)}
instance Storable CS4
where {sizeOf = \_ -> 8;
alignment = \_ -> 4;
peek = \x_0 -> (pure MkCS4 <*> peekByteOff x_0 0) <*> peekByteOff x_0 32;
where {sizeOf = \_ -> 16;
alignment = \_ -> 8;
peek = \x_0 -> ((pure MkCS4 <*> peekByteOff x_0 0) <*> peekByteOff x_0 32) <*> peekByteOff x_0 64;
poke = \x_1 -> \x_2 -> case x_2 of
{MkCS4 cS4_b_3
cS4_a_4 -> pokeByteOff x_1 0 cS4_b_3 >> pokeByteOff x_1 32 cS4_a_4}}
cS4_a_4
cS4_c_5 -> pokeByteOff x_1 0 cS4_b_3 >> (pokeByteOff x_1 32 cS4_a_4 >> pokeByteOff x_1 64 cS4_c_5)}}
11 changes: 8 additions & 3 deletions hs-bindgen/fixtures/simple_structs.tree-diff.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -90,8 +90,8 @@ WrapCHeader
DeclStruct
Struct {
structTag = Just (CName "S4"),
structSizeof = 8,
structAlignment = 4,
structSizeof = 16,
structAlignment = 8,
structFields = [
StructField {
fieldName = CName "b",
Expand All @@ -102,4 +102,9 @@ WrapCHeader
fieldName = CName "a",
fieldOffset = 32,
fieldType = TypPrim
(PrimInt Signed)}]}])
(PrimInt Signed)},
StructField {
fieldName = CName "c",
fieldOffset = 64,
fieldType = TypPointer
(TypPrim (PrimInt Signed))}]}])
1 change: 1 addition & 0 deletions hs-bindgen/src/HsBindgen/Backend/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,6 +48,7 @@ data Global =
| Storable_pokeByteOff
| Storable_peek
| Storable_poke
| Foreign_Ptr

| PrimType HsPrimType

Expand Down
5 changes: 3 additions & 2 deletions hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -67,9 +67,10 @@ instance Backend be => ToBE be (Hs.WithStruct Hs.DataDecl) where
Types
-------------------------------------------------------------------------------}

typeToBE :: {- Backend be => -} Hs.HsType -> SType be
typeToBE :: Hs.HsType -> SType be
typeToBE (Hs.HsPrimType t) = TGlobal (PrimType t)
typeToBE _ = TGlobal (PrimType HsPrimVoid)
typeToBE (Hs.HsPtr t) = TApp (TGlobal Foreign_Ptr) (typeToBE t)
typeToBE _ = TGlobal (PrimType HsPrimVoid)

{-------------------------------------------------------------------------------
'Storable'
Expand Down
2 changes: 2 additions & 0 deletions hs-bindgen/src/HsBindgen/Backend/TH.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ import Data.Kind (Type)
import Data.Text qualified as Text
import Data.Void qualified
import Foreign.C.Types qualified
import Foreign.Ptr qualified
import Foreign.Storable qualified
import Language.Haskell.TH (Quote)
import Language.Haskell.TH qualified as TH
Expand Down Expand Up @@ -46,6 +47,7 @@ instance TH.Quote q => BackendRep (BE q) where
Storable_pokeByteOff -> 'Foreign.Storable.pokeByteOff
Storable_peek -> 'Foreign.Storable.peek
Storable_poke -> 'Foreign.Storable.poke
Foreign_Ptr -> ''Foreign.Ptr.Ptr
PrimType t -> resolveP t
where
resolveP HsPrimVoid = ''Data.Void.Void
Expand Down
1 change: 1 addition & 0 deletions hs-bindgen/src/HsBindgen/Hs/AST/Type.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,4 +43,5 @@ data HsPrimType
data HsType =
HsType String
| HsPrimType HsPrimType
| HsPtr HsType
deriving stock (Show)
2 changes: 1 addition & 1 deletion hs-bindgen/src/HsBindgen/Translation/LowLevel.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -173,4 +173,4 @@ typ (C.TypPrim p) = case p of
C.PrimFloat -> Hs.HsPrimType HsPrimCFloat
C.PrimDouble -> Hs.HsPrimType HsPrimCDouble
C.PrimLongDouble -> Hs.HsPrimType HsPrimCDouble -- not sure this is correct.
typ (C.TypPointer _t) = Hs.HsType "pointer" -- also wrong
typ (C.TypPointer t) = Hs.HsPtr (typ t)

0 comments on commit 7733235

Please sign in to comment.