diff --git a/hs-bindgen/examples/simple_structs.h b/hs-bindgen/examples/simple_structs.h index 99be6c9a..fab26074 100644 --- a/hs-bindgen/examples/simple_structs.h +++ b/hs-bindgen/examples/simple_structs.h @@ -19,4 +19,5 @@ typedef struct { struct S4 { char b; int a; + int *c; }; diff --git a/hs-bindgen/fixtures/simple_structs.hs b/hs-bindgen/fixtures/simple_structs.hs index f9209626..e7e66c92 100644 --- a/hs-bindgen/fixtures/simple_structs.hs +++ b/hs-bindgen/fixtures/simple_structs.hs @@ -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]}))))})))]} diff --git a/hs-bindgen/fixtures/simple_structs.th.txt b/hs-bindgen/fixtures/simple_structs.th.txt index 8966f576..f392b637 100644 --- a/hs-bindgen/fixtures/simple_structs.th.txt +++ b/hs-bindgen/fixtures/simple_structs.th.txt @@ -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)}} diff --git a/hs-bindgen/fixtures/simple_structs.tree-diff.txt b/hs-bindgen/fixtures/simple_structs.tree-diff.txt index 75dc017f..5c5db5c3 100644 --- a/hs-bindgen/fixtures/simple_structs.tree-diff.txt +++ b/hs-bindgen/fixtures/simple_structs.tree-diff.txt @@ -90,8 +90,8 @@ WrapCHeader DeclStruct Struct { structTag = Just (CName "S4"), - structSizeof = 8, - structAlignment = 4, + structSizeof = 16, + structAlignment = 8, structFields = [ StructField { fieldName = CName "b", @@ -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))}]}]) diff --git a/hs-bindgen/src/HsBindgen/Backend/Common.hs b/hs-bindgen/src/HsBindgen/Backend/Common.hs index ca929969..abcfd695 100644 --- a/hs-bindgen/src/HsBindgen/Backend/Common.hs +++ b/hs-bindgen/src/HsBindgen/Backend/Common.hs @@ -48,6 +48,7 @@ data Global = | Storable_pokeByteOff | Storable_peek | Storable_poke + | Foreign_Ptr | PrimType HsPrimType diff --git a/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs index fd3fe1ba..f04a800b 100644 --- a/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs +++ b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs @@ -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' diff --git a/hs-bindgen/src/HsBindgen/Backend/TH.hs b/hs-bindgen/src/HsBindgen/Backend/TH.hs index ea36561a..24e6deee 100644 --- a/hs-bindgen/src/HsBindgen/Backend/TH.hs +++ b/hs-bindgen/src/HsBindgen/Backend/TH.hs @@ -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 @@ -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 diff --git a/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs b/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs index 2148ad28..077316a0 100644 --- a/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs +++ b/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs @@ -43,4 +43,5 @@ data HsPrimType data HsType = HsType String | HsPrimType HsPrimType + | HsPtr HsType deriving stock (Show) diff --git a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs index 323ff551..454afedc 100644 --- a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs +++ b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs @@ -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)