Merge pull request #242 from well-typed/data-decl-cons-c

Add pointer types

hs-bindgen/examples/simple_structs.h

@@ -19,4 +19,5 @@ typedef struct {
 struct S4 {
     char b;
     int a;
+    int *c;
 };

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]}))))})))]}

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)}}

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))}]}])

hs-bindgen/src/HsBindgen/Backend/Common.hs

@@ -48,6 +48,7 @@ data Global =
   | Storable_pokeByteOff
   | Storable_peek
   | Storable_poke
+  | Foreign_Ptr
 
   | PrimType HsPrimType
 

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'

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

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)

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)