From 54f3a849aa2f794a606aafde90917545b939901f Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 29 Oct 2024 14:43:08 +0200 Subject: [PATCH] Add HsTypRef for handling TypElaborated --- hs-bindgen/fixtures/fixedwidth.hs | 2 +- hs-bindgen/fixtures/fixedwidth.th.txt | 2 +- hs-bindgen/fixtures/nested_types.hs | 2 +- hs-bindgen/fixtures/nested_types.th.txt | 4 +++- hs-bindgen/fixtures/typedef_vs_macro.hs | 2 +- hs-bindgen/fixtures/typedef_vs_macro.th.txt | 8 ++++---- .../src/HsBindgen/Backend/Common/Translation.hs | 1 + hs-bindgen/src/HsBindgen/Hs/AST/Type.hs | 3 +++ hs-bindgen/src/HsBindgen/Translation/LowLevel.hs | 13 +++++++------ 9 files changed, 22 insertions(+), 15 deletions(-) diff --git a/hs-bindgen/fixtures/fixedwidth.hs b/hs-bindgen/fixtures/fixedwidth.hs index b6698e97..7d6183e4 100644 --- a/hs-bindgen/fixtures/fixedwidth.hs +++ b/hs-bindgen/fixtures/fixedwidth.hs @@ -1 +1 @@ -List {getList = [DeclData (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsType "\"uint64_t\"") ::: ("cFoo_thirty_two",HsType "\"uint32_t\"") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsType "\"uint64_t\"") ::: ("cFoo_thirty_two",HsType "\"uint32_t\"") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 8, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsType "\"uint64_t\"") ::: ("cFoo_thirty_two",HsType "\"uint32_t\"") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsType "\"uint64_t\"") ::: ("cFoo_thirty_two",HsType "\"uint32_t\"") ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 64 x2]}))))})))]} +List {getList = [DeclData (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsTypRef "CUint64T") ::: ("cFoo_thirty_two",HsTypRef "CUint32T") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsTypRef "CUint64T") ::: ("cFoo_thirty_two",HsTypRef "CUint32T") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 8, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsTypRef "CUint64T") ::: ("cFoo_thirty_two",HsTypRef "CUint32T") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_sixty_four",HsTypRef "CUint64T") ::: ("cFoo_thirty_two",HsTypRef "CUint32T") ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 64 x2]}))))})))]} diff --git a/hs-bindgen/fixtures/fixedwidth.th.txt b/hs-bindgen/fixtures/fixedwidth.th.txt index 68f2c424..396ce3bb 100644 --- a/hs-bindgen/fixtures/fixedwidth.th.txt +++ b/hs-bindgen/fixtures/fixedwidth.th.txt @@ -1,5 +1,5 @@ data CFoo - = MkCFoo {cFoo_sixty_four :: Void, cFoo_thirty_two :: Void} + = MkCFoo {cFoo_sixty_four :: CUint64T, cFoo_thirty_two :: CUint32T} instance Storable CFoo where {sizeOf = \_ -> 16; alignment = \_ -> 8; diff --git a/hs-bindgen/fixtures/nested_types.hs b/hs-bindgen/fixtures/nested_types.hs index d1b9cdec..a857ae0b 100644 --- a/hs-bindgen/fixtures/nested_types.hs +++ b/hs-bindgen/fixtures/nested_types.hs @@ -1 +1 @@ -List {getList = [DeclData (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclData (WithStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsType "\"struct foo\"") ::: ("cBar_foo2",HsType "\"struct foo\"") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsType "\"struct foo\"") ::: ("cBar_foo2",HsType "\"struct foo\"") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsType "\"struct foo\"") ::: ("cBar_foo2",HsType "\"struct foo\"") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsType "\"struct foo\"") ::: ("cBar_foo2",HsType "\"struct foo\"") ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 64 x2]}))))})))]} +List {getList = [DeclData (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("cFoo_i",HsPrimType HsPrimCInt) ::: ("cFoo_c",HsPrimType HsPrimCChar) ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclData (WithStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsTypRef "CStruct'0020foo") ::: ("cBar_foo2",HsTypRef "CStruct'0020foo") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsTypRef "CStruct'0020foo") ::: ("cBar_foo2",HsTypRef "CStruct'0020foo") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsTypRef "CStruct'0020foo") ::: ("cBar_foo2",HsTypRef "CStruct'0020foo") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CBar", structConstr = "MkCBar", structFields = ("cBar_foo1",HsTypRef "CStruct'0020foo") ::: ("cBar_foo2",HsTypRef "CStruct'0020foo") ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 64 x2]}))))})))]} diff --git a/hs-bindgen/fixtures/nested_types.th.txt b/hs-bindgen/fixtures/nested_types.th.txt index d14600b0..199c480e 100644 --- a/hs-bindgen/fixtures/nested_types.th.txt +++ b/hs-bindgen/fixtures/nested_types.th.txt @@ -6,7 +6,9 @@ instance Storable CFoo poke = \x_1 -> \x_2 -> case x_2 of {MkCFoo cFoo_i_3 cFoo_c_4 -> pokeByteOff x_1 0 cFoo_i_3 >> pokeByteOff x_1 32 cFoo_c_4}} -data CBar = MkCBar {cBar_foo1 :: Void, cBar_foo2 :: Void} +data CBar + = MkCBar {cBar_foo1 :: CStruct'0020foo, + cBar_foo2 :: CStruct'0020foo} instance Storable CBar where {sizeOf = \_ -> 16; alignment = \_ -> 4; diff --git a/hs-bindgen/fixtures/typedef_vs_macro.hs b/hs-bindgen/fixtures/typedef_vs_macro.hs index 0a799af8..ad7117f9 100644 --- a/hs-bindgen/fixtures/typedef_vs_macro.hs +++ b/hs-bindgen/fixtures/typedef_vs_macro.hs @@ -1 +1 @@ -List {getList = [DeclData (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsType "\"T1\"") ::: ("cExampleStruct_t2",HsType "\"T2\"") ::: ("cExampleStruct_m1",HsType "\"M1\"") ::: ("cExampleStruct_m2",HsType "\"M2\"") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsType "\"T1\"") ::: ("cExampleStruct_t2",HsType "\"T2\"") ::: ("cExampleStruct_m1",HsType "\"M1\"") ::: ("cExampleStruct_m2",HsType "\"M2\"") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsType "\"T1\"") ::: ("cExampleStruct_t2",HsType "\"T2\"") ::: ("cExampleStruct_m1",HsType "\"M1\"") ::: ("cExampleStruct_m2",HsType "\"M2\"") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64, PeekByteOff x0 96]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsType "\"T1\"") ::: ("cExampleStruct_t2",HsType "\"T2\"") ::: ("cExampleStruct_m1",HsType "\"M1\"") ::: ("cExampleStruct_m2",HsType "\"M2\"") ::: VNil}) (\(x1 ::: x2 ::: x3 ::: x4 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3, PokeByteOff x0 96 x4]}))))})))]} +List {getList = [DeclData (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (MkDataDecl)), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64, PeekByteOff x0 96]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "CExampleStruct", structConstr = "MkCExampleStruct", structFields = ("cExampleStruct_t1",HsTypRef "CT1") ::: ("cExampleStruct_t2",HsTypRef "CT2") ::: ("cExampleStruct_m1",HsTypRef "CM1") ::: ("cExampleStruct_m2",HsTypRef "CM2") ::: VNil}) (\(x1 ::: x2 ::: x3 ::: x4 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3, PokeByteOff x0 96 x4]}))))})))]} diff --git a/hs-bindgen/fixtures/typedef_vs_macro.th.txt b/hs-bindgen/fixtures/typedef_vs_macro.th.txt index 167d01de..43bc5fdd 100644 --- a/hs-bindgen/fixtures/typedef_vs_macro.th.txt +++ b/hs-bindgen/fixtures/typedef_vs_macro.th.txt @@ -1,8 +1,8 @@ data CExampleStruct - = MkCExampleStruct {cExampleStruct_t1 :: Void, - cExampleStruct_t2 :: Void, - cExampleStruct_m1 :: Void, - cExampleStruct_m2 :: Void} + = MkCExampleStruct {cExampleStruct_t1 :: CT1, + cExampleStruct_t2 :: CT2, + cExampleStruct_m1 :: CM1, + cExampleStruct_m2 :: CM2} instance Storable CExampleStruct where {sizeOf = \_ -> 16; alignment = \_ -> 4; diff --git a/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs index f04a800b..dd0ab607 100644 --- a/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs +++ b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs @@ -69,6 +69,7 @@ instance Backend be => ToBE be (Hs.WithStruct Hs.DataDecl) where typeToBE :: Hs.HsType -> SType be typeToBE (Hs.HsPrimType t) = TGlobal (PrimType t) +typeToBE (Hs.HsTypRef r) = TCon r typeToBE (Hs.HsPtr t) = TApp (TGlobal Foreign_Ptr) (typeToBE t) typeToBE _ = TGlobal (PrimType HsPrimVoid) diff --git a/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs b/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs index 077316a0..d515535e 100644 --- a/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs +++ b/hs-bindgen/src/HsBindgen/Hs/AST/Type.hs @@ -3,6 +3,8 @@ module HsBindgen.Hs.AST.Type ( HsType (..), ) where +import HsBindgen.Hs.AST.Name + {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} @@ -43,5 +45,6 @@ data HsPrimType data HsType = HsType String | HsPrimType HsPrimType + | HsTypRef (HsName NsTypeConstr) | HsPtr HsType deriving stock (Show) diff --git a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs index 454afedc..9f68ea76 100644 --- a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs +++ b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs @@ -87,7 +87,7 @@ structDecs struct fields = List mkField f = ( toHsName opts (FieldContext structName structConstr True) $ C.fieldName f - , typ (C.fieldType f) + , typ opts (C.fieldType f) ) structFields = Vec.map mkField fields in Hs.Struct{..} @@ -154,10 +154,11 @@ enumDecs e = List [ Types -------------------------------------------------------------------------------} -typ :: C.Typ -> Hs.HsType -typ (C.TypElaborated c) = Hs.HsType (show c) -- wrong -typ (C.TypStruct s) = Hs.HsType (show (C.structTag s)) -- also wrong -typ (C.TypPrim p) = case p of +typ :: NameManglingOptions -> C.Typ -> Hs.HsType +typ opts (C.TypElaborated c) = + Hs.HsTypRef (toHsName opts EmptyNsTypeConstrContext c) -- wrong +typ _ (C.TypStruct s) =Hs.HsType (show (C.structTag s)) -- also wrong +typ _ (C.TypPrim p) = case p of C.PrimVoid -> Hs.HsPrimType HsPrimVoid C.PrimChar Nothing -> Hs.HsPrimType HsPrimCChar C.PrimChar (Just C.Signed) -> Hs.HsPrimType HsPrimCSChar @@ -173,4 +174,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.HsPtr (typ t) +typ opts (C.TypPointer t) = Hs.HsPtr (typ opts t)