Merge pull request #243 from well-typed/data-decl-cons-d

Add HsTypRef for handling TypElaborated
well-typed · Oct 30, 2024 · 5404537 · 5404537
2 parents d194cba + 54f3a84
commit 5404537
Show file tree

Hide file tree

Showing 9 changed files with 22 additions and 15 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)