From cd761768ebb6aba20539b8466e4811615403c827 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 6 Sep 2024 09:50:36 +0200 Subject: [PATCH] Introduce Haskell AST and multiple backends This also * Adds a struct offset field (closes #133) * Starts the translation from C to Haskell for structs * Provide infrastructure for PHOAS, including generics for deriving lawful (parseable) `Show`. --- hs-bindgen-libclang/cbits/clang_wrappers.h | 4 + .../src/HsBindgen/Clang/Core.hs | 12 ++ hs-bindgen/fixtures/enums.hs | 1 + hs-bindgen/fixtures/enums.th.txt | 0 hs-bindgen/fixtures/macro_functions.hs | 1 + hs-bindgen/fixtures/macro_functions.th.txt | 0 hs-bindgen/fixtures/macros.hs | 1 + hs-bindgen/fixtures/macros.th.txt | 0 hs-bindgen/fixtures/nested_types.hs | 1 + hs-bindgen/fixtures/nested_types.th.txt | 0 .../fixtures/nested_types.tree-diff.txt | 2 + hs-bindgen/fixtures/primitive_types.hs | 1 + hs-bindgen/fixtures/primitive_types.th.txt | 0 .../fixtures/primitive_types.tree-diff.txt | 5 + hs-bindgen/fixtures/simple_structs.hs | 1 + hs-bindgen/fixtures/simple_structs.th.txt | 0 .../fixtures/simple_structs.tree-diff.txt | 12 ++ hs-bindgen/hs-bindgen.cabal | 53 ++++- hs-bindgen/src/HsBindgen/Backend/Common.hs | 78 +++++++ .../HsBindgen/Backend/Common/Translation.hs | 146 +++++++++++++ hs-bindgen/src/HsBindgen/Backend/HsSrcExts.hs | 156 ++++++++++++++ .../{Hs => Backend/HsSrcExts}/Render.hs | 12 +- .../Backend/HsSrcExts/Translation.hs | 54 +++++ hs-bindgen/src/HsBindgen/Backend/TH.hs | 92 ++++++++ .../src/HsBindgen/Backend/TH/Translation.hs | 29 +++ hs-bindgen/src/HsBindgen/C/AST.hs | 5 +- hs-bindgen/src/HsBindgen/C/Parser.hs | 5 +- hs-bindgen/src/HsBindgen/Hs/AST.hs | 198 ++++++++++++++++++ hs-bindgen/src/HsBindgen/Hs/Annotation.hs | 36 ---- hs-bindgen/src/HsBindgen/Lib.hs | 38 ++-- hs-bindgen/src/HsBindgen/TH.hs | 5 +- .../src/HsBindgen/Translation/LowLevel.hs | 111 ++++++---- hs-bindgen/src/HsBindgen/Util/PHOAS.hs | 164 +++++++++++++++ .../test-th/HsBindgen/TestTH/Examples.hs | 58 +++++ .../test-th/HsBindgen/TestTH/Spliced.hs | 10 + hs-bindgen/test-th/TestTH.hs | 10 + hs-bindgen/tests/golden.hs | 16 +- 37 files changed, 1197 insertions(+), 120 deletions(-) create mode 100644 hs-bindgen/fixtures/enums.hs delete mode 100644 hs-bindgen/fixtures/enums.th.txt create mode 100644 hs-bindgen/fixtures/macro_functions.hs delete mode 100644 hs-bindgen/fixtures/macro_functions.th.txt create mode 100644 hs-bindgen/fixtures/macros.hs delete mode 100644 hs-bindgen/fixtures/macros.th.txt create mode 100644 hs-bindgen/fixtures/nested_types.hs delete mode 100644 hs-bindgen/fixtures/nested_types.th.txt create mode 100644 hs-bindgen/fixtures/primitive_types.hs delete mode 100644 hs-bindgen/fixtures/primitive_types.th.txt create mode 100644 hs-bindgen/fixtures/simple_structs.hs delete mode 100644 hs-bindgen/fixtures/simple_structs.th.txt create mode 100644 hs-bindgen/src/HsBindgen/Backend/Common.hs create mode 100644 hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs create mode 100644 hs-bindgen/src/HsBindgen/Backend/HsSrcExts.hs rename hs-bindgen/src/HsBindgen/{Hs => Backend/HsSrcExts}/Render.hs (91%) create mode 100644 hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Translation.hs create mode 100644 hs-bindgen/src/HsBindgen/Backend/TH.hs create mode 100644 hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs create mode 100644 hs-bindgen/src/HsBindgen/Hs/AST.hs delete mode 100644 hs-bindgen/src/HsBindgen/Hs/Annotation.hs create mode 100644 hs-bindgen/src/HsBindgen/Util/PHOAS.hs create mode 100644 hs-bindgen/test-th/HsBindgen/TestTH/Examples.hs create mode 100644 hs-bindgen/test-th/HsBindgen/TestTH/Spliced.hs create mode 100644 hs-bindgen/test-th/TestTH.hs diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.h b/hs-bindgen-libclang/cbits/clang_wrappers.h index 50dcdf5d..96b29af6 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.h +++ b/hs-bindgen-libclang/cbits/clang_wrappers.h @@ -138,6 +138,10 @@ static inline unsigned wrap_Type_isTransparentTagTypedef(const CXType *T) { return clang_Type_isTransparentTagTypedef(*T); } +static inline long long wrap_Cursor_getOffsetOfField(const CXCursor* C) { + return clang_Cursor_getOffsetOfField(*C); +} + static inline unsigned wrap_Cursor_isAnonymous(const CXCursor* C) { return clang_Cursor_isAnonymous(*C); } diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs index 13494a30..e0c82790 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs @@ -100,6 +100,7 @@ module HsBindgen.Clang.Core ( , clang_Type_getSizeOf , clang_Type_getAlignOf , clang_Type_isTransparentTagTypedef + , clang_Cursor_getOffsetOfField , clang_Cursor_isAnonymous , clang_getEnumConstantDeclValue -- * Mapping between cursors and source code @@ -687,6 +688,9 @@ foreign import capi unsafe "clang_wrappers.h wrap_Type_getAlignOf" foreign import capi unsafe "clang_wrappers.h wrap_Type_isTransparentTagTypedef" wrap_Type_isTransparentTagTypedef :: R CXType_ -> IO CUInt +foreign import capi unsafe "clang_wrappers.h wrap_Cursor_getOffsetOfField" + wrap_Cursor_getOffsetOfField :: R CXCursor_ -> IO CLLong + foreign import capi unsafe "clang_wrappers.h wrap_Cursor_isAnonymous" wrap_Cursor_isAnonymous :: R CXCursor_ -> IO CUInt @@ -767,6 +771,14 @@ clang_Type_isTransparentTagTypedef typ = onHaskellHeap typ $ \typ' -> cToBool <$> wrap_Type_isTransparentTagTypedef typ' +-- | Return the offset of the field represented by the Cursor. +-- +-- +clang_Cursor_getOffsetOfField :: CXCursor -> IO CLLong +clang_Cursor_getOffsetOfField cursor = + onHaskellHeap cursor $ \cursor' -> + wrap_Cursor_getOffsetOfField cursor' + -- | Determine whether the given cursor represents an anonymous tag or -- namespace. -- diff --git a/hs-bindgen/fixtures/enums.hs b/hs-bindgen/fixtures/enums.hs new file mode 100644 index 00000000..1ca32401 --- /dev/null +++ b/hs-bindgen/fixtures/enums.hs @@ -0,0 +1 @@ +List {getList = []} \ No newline at end of file diff --git a/hs-bindgen/fixtures/enums.th.txt b/hs-bindgen/fixtures/enums.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/macro_functions.hs b/hs-bindgen/fixtures/macro_functions.hs new file mode 100644 index 00000000..1ca32401 --- /dev/null +++ b/hs-bindgen/fixtures/macro_functions.hs @@ -0,0 +1 @@ +List {getList = []} \ No newline at end of file diff --git a/hs-bindgen/fixtures/macro_functions.th.txt b/hs-bindgen/fixtures/macro_functions.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/macros.hs b/hs-bindgen/fixtures/macros.hs new file mode 100644 index 00000000..1ca32401 --- /dev/null +++ b/hs-bindgen/fixtures/macros.hs @@ -0,0 +1 @@ +List {getList = []} \ No newline at end of file diff --git a/hs-bindgen/fixtures/macros.th.txt b/hs-bindgen/fixtures/macros.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/nested_types.hs b/hs-bindgen/fixtures/nested_types.hs new file mode 100644 index 00000000..7c2d0923 --- /dev/null +++ b/hs-bindgen/fixtures/nested_types.hs @@ -0,0 +1 @@ +List {getList = [DeclInstance (InstanceStorable (WithStruct (Struct {structName = "foo", structConstr = "Mkfoo", structFields = "i" ::: "c" ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "foo", structConstr = "Mkfoo", structFields = "i" ::: "c" ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "foo", structConstr = "Mkfoo", structFields = "i" ::: "c" ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "bar", structConstr = "Mkbar", structFields = VNil}) (StorableInstance {storableSizeOf = 16, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "bar", structConstr = "Mkbar", structFields = VNil})) []), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "bar", structConstr = "Mkbar", structFields = VNil}) (\( ::: VNil) -> (Seq (List {getList = []}))))})))]} \ No newline at end of file diff --git a/hs-bindgen/fixtures/nested_types.th.txt b/hs-bindgen/fixtures/nested_types.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/nested_types.tree-diff.txt b/hs-bindgen/fixtures/nested_types.tree-diff.txt index 8466f031..c7665a0d 100644 --- a/hs-bindgen/fixtures/nested_types.tree-diff.txt +++ b/hs-bindgen/fixtures/nested_types.tree-diff.txt @@ -9,9 +9,11 @@ WrapCHeader structFields = [ StructField { fieldName = "i", + fieldOffset = 0, fieldType = PrimInt}, StructField { fieldName = "c", + fieldOffset = 32, fieldType = PrimChar}]}, DeclStruct Struct { diff --git a/hs-bindgen/fixtures/primitive_types.hs b/hs-bindgen/fixtures/primitive_types.hs new file mode 100644 index 00000000..bc53166a --- /dev/null +++ b/hs-bindgen/fixtures/primitive_types.hs @@ -0,0 +1 @@ +List {getList = [DeclInstance (InstanceStorable (WithStruct (Struct {structName = "primitive", structConstr = "Mkprimitive", structFields = "c" ::: "i" ::: "s2" ::: "si2" ::: "f" ::: VNil}) (StorableInstance {storableSizeOf = 176, storableAlignment = 16, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "primitive", structConstr = "Mkprimitive", structFields = "c" ::: "i" ::: "s2" ::: "si2" ::: "f" ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 128, PeekByteOff x0 160, PeekByteOff x0 192, PeekByteOff x0 1088]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "primitive", structConstr = "Mkprimitive", structFields = "c" ::: "i" ::: "s2" ::: "si2" ::: "f" ::: VNil}) (\(x1 ::: x2 ::: x3 ::: x4 ::: x5 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 128 x2, PokeByteOff x0 160 x3, PokeByteOff x0 192 x4, PokeByteOff x0 1088 x5]}))))})))]} \ No newline at end of file diff --git a/hs-bindgen/fixtures/primitive_types.th.txt b/hs-bindgen/fixtures/primitive_types.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/primitive_types.tree-diff.txt b/hs-bindgen/fixtures/primitive_types.tree-diff.txt index c7d275c2..64d11a67 100644 --- a/hs-bindgen/fixtures/primitive_types.tree-diff.txt +++ b/hs-bindgen/fixtures/primitive_types.tree-diff.txt @@ -9,16 +9,21 @@ WrapCHeader structFields = [ StructField { fieldName = "c", + fieldOffset = 0, fieldType = PrimChar}, StructField { fieldName = "i", + fieldOffset = 128, fieldType = PrimInt}, StructField { fieldName = "s2", + fieldOffset = 160, fieldType = PrimInt}, StructField { fieldName = "si2", + fieldOffset = 192, fieldType = PrimInt}, StructField { fieldName = "f", + fieldOffset = 1088, fieldType = PrimFloat}]}]) diff --git a/hs-bindgen/fixtures/simple_structs.hs b/hs-bindgen/fixtures/simple_structs.hs new file mode 100644 index 00000000..cc82e7a0 --- /dev/null +++ b/hs-bindgen/fixtures/simple_structs.hs @@ -0,0 +1 @@ +List {getList = [DeclInstance (InstanceStorable (WithStruct (Struct {structName = "S1", structConstr = "MkS1", structFields = "a" ::: "b" ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "S1", structConstr = "MkS1", structFields = "a" ::: "b" ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "S1", structConstr = "MkS1", structFields = "a" ::: "b" ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))}))), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "S2", structConstr = "MkS2", structFields = "a" ::: "b" ::: "c" ::: VNil}) (StorableInstance {storableSizeOf = 12, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "S2", structConstr = "MkS2", structFields = "a" ::: "b" ::: "c" ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32, PeekByteOff x0 64]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "S2", structConstr = "MkS2", structFields = "a" ::: "b" ::: "c" ::: VNil}) (\(x1 ::: x2 ::: x3 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2, PokeByteOff x0 64 x3]}))))}))), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "X", structConstr = "MkX", structFields = "a" ::: VNil}) (StorableInstance {storableSizeOf = 1, storableAlignment = 1, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "X", structConstr = "MkX", structFields = "a" ::: VNil})) [PeekByteOff x0 0]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "X", structConstr = "MkX", structFields = "a" ::: VNil}) (\(x1 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1]}))))}))), DeclInstance (InstanceStorable (WithStruct (Struct {structName = "S4", structConstr = "MkS4", structFields = "b" ::: "a" ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda (\x0 -> Ap (IntroStruct (Struct {structName = "S4", structConstr = "MkS4", structFields = "b" ::: "a" ::: VNil})) [PeekByteOff x0 0, PeekByteOff x0 32]), storablePoke = Lambda (\x0 -> ElimStruct (Struct {structName = "S4", structConstr = "MkS4", structFields = "b" ::: "a" ::: VNil}) (\(x1 ::: x2 ::: VNil) -> (Seq (List {getList = [PokeByteOff x0 0 x1, PokeByteOff x0 32 x2]}))))})))]} \ No newline at end of file diff --git a/hs-bindgen/fixtures/simple_structs.th.txt b/hs-bindgen/fixtures/simple_structs.th.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/hs-bindgen/fixtures/simple_structs.tree-diff.txt b/hs-bindgen/fixtures/simple_structs.tree-diff.txt index c7281e7c..28b9df95 100644 --- a/hs-bindgen/fixtures/simple_structs.tree-diff.txt +++ b/hs-bindgen/fixtures/simple_structs.tree-diff.txt @@ -9,9 +9,11 @@ WrapCHeader structFields = [ StructField { fieldName = "a", + fieldOffset = 0, fieldType = PrimInt}, StructField { fieldName = "b", + fieldOffset = 32, fieldType = PrimChar}]}, DeclStruct Struct { @@ -21,12 +23,15 @@ WrapCHeader structFields = [ StructField { fieldName = "a", + fieldOffset = 0, fieldType = PrimChar}, StructField { fieldName = "b", + fieldOffset = 32, fieldType = PrimInt}, StructField { fieldName = "c", + fieldOffset = 64, fieldType = PrimFloat}]}, DeclTypedef Typedef { @@ -39,12 +44,15 @@ WrapCHeader structFields = [ StructField { fieldName = "a", + fieldOffset = 0, fieldType = PrimChar}, StructField { fieldName = "b", + fieldOffset = 32, fieldType = PrimInt}, StructField { fieldName = "c", + fieldOffset = 64, fieldType = PrimFloat}]}}, DeclStruct Struct { @@ -54,6 +62,7 @@ WrapCHeader structFields = [ StructField { fieldName = "a", + fieldOffset = 0, fieldType = PrimChar}]}, DeclTypedef Typedef { @@ -66,6 +75,7 @@ WrapCHeader structFields = [ StructField { fieldName = "a", + fieldOffset = 0, fieldType = PrimChar}]}}, DeclStruct Struct { @@ -75,7 +85,9 @@ WrapCHeader structFields = [ StructField { fieldName = "b", + fieldOffset = 0, fieldType = PrimChar}, StructField { fieldName = "a", + fieldOffset = 32, fieldType = PrimInt}]}]) diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 3e498065..3a7eeae5 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/hs-bindgen/hs-bindgen.cabal @@ -28,10 +28,16 @@ common lang default-language: GHC2021 default-extensions: + DataKinds + DefaultSignatures DeriveAnyClass DerivingStrategies + DerivingVia DisambiguateRecordFields + LambdaCase + QuantifiedConstraints TypeFamilies + UndecidableInstances library import: lang @@ -41,13 +47,22 @@ library HsBindgen.Lib HsBindgen.TH exposed-modules: + HsBindgen.Backend.Common + HsBindgen.Backend.Common.Translation + HsBindgen.Backend.HsSrcExts + HsBindgen.Backend.HsSrcExts.Render + HsBindgen.Backend.HsSrcExts.Translation + HsBindgen.Backend.TH + HsBindgen.Backend.TH.Translation HsBindgen.C.AST HsBindgen.C.Parser HsBindgen.C.Predicate - HsBindgen.Hs.Annotation - HsBindgen.Hs.Render + HsBindgen.Hs.AST HsBindgen.Translation.LowLevel + HsBindgen.Util.PHOAS HsBindgen.Util.Tracer + other-extensions: + TemplateHaskellQuotes build-depends: -- Internal dependencies , hs-bindgen-patterns @@ -58,12 +73,14 @@ library , containers >= 0.6.5.1 && < 0.8 , contra-tracer >= 0.2 && < 0.3 , data-default >= 0.7 && < 0.8 + , fin >= 0.3 && < 0.4 + , generics-sop >= 0.5 && < 0.6 , haskell-src-exts >= 1.23 && < 1.24 - , haskell-src-meta >= 0.8 && < 0.9 , mtl >= 2.2 && < 2.4 , pretty-show >= 1.10 && < 1.11 , regex-pcre-builtin >= 0.95 && < 0.96 , template-haskell >= 2.18 && < 2.23 + , vec >= 0.5 && < 0.6 executable hs-bindgen import: lang @@ -82,11 +99,6 @@ executable hs-bindgen , containers , data-default build-depends: - -- External dependencies - -- - -- NOTE: Ideally this should not depend on haskell-src-exts or - -- haskell-src-meta; functionality that requires these libraries should - -- live in the library instead. , blaze-html >= 0.9 && < 0.10 , blaze-markup >= 0.8 && < 0.9 , optparse-applicative >= 0.18 && < 0.19 @@ -105,7 +117,6 @@ test-suite golden -- Inherited dependencies , containers , bytestring - , template-haskell build-depends: -- External dependencies , directory ^>=1.3.6.2 @@ -114,3 +125,27 @@ test-suite golden , tasty-golden ^>=2.3.5 , tasty-hunit ^>=0.10.2 , tree-diff ^>=0.3.1 + +test-suite test-th + import: lang + type: exitcode-stdio-1.0 + main-is: TestTH.hs + hs-source-dirs: test-th + + other-extensions: + TemplateHaskell + other-modules: + HsBindgen.TestTH.Examples + HsBindgen.TestTH.Spliced + build-depends: + -- Internal dependencies + , hs-bindgen + build-depends: + -- Inherited dependencies + fin + , vec + build-depends: + -- External dependencies + , tasty >= 1.5 && < 1.6 + + diff --git a/hs-bindgen/src/HsBindgen/Backend/Common.hs b/hs-bindgen/src/HsBindgen/Backend/Common.hs new file mode 100644 index 00000000..96035204 --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/Common.hs @@ -0,0 +1,78 @@ +-- | Common backend functionality +module HsBindgen.Backend.Common ( + -- * Representation + BackendRep(..) + , Global(..) + , SExpr(..) + , SDecl(..) + , Instance(..) + -- * Full backend + , Backend(..) + , Fresh(..) + ) where + +import Data.Kind + +import HsBindgen.Util.PHOAS + +{------------------------------------------------------------------------------- + Backend representation +-------------------------------------------------------------------------------} + +class BackendRep be where + type Name be :: Type + type Expr be :: Type + type Decl be :: Type + + resolve :: be -> Global -> Name be -- ^ Resolve name + mkExpr :: be -> SExpr be -> Expr be -- ^ Construct expression + mkDecl :: be -> SDecl be -> Decl be -- ^ Construct declaration + +data Global = + Applicative_pure + | Applicative_seq + | Monad_seq + | Storable_Storable + | Storable_sizeOf + | Storable_alignment + | Storable_peekByteOff + | Storable_pokeByteOff + | Storable_peek + | Storable_poke + +-- | Simple expressions +data SExpr be = + EGlobal Global + | EVar (Fresh be Bound) + | ECon String + | EInt Int + | EApp (SExpr be) (SExpr be) + | EInfix Global (SExpr be) (SExpr be) + | ELam (Maybe (Fresh be Bound)) (SExpr be) + | ECase (SExpr be) [(String, [Fresh be Bound], SExpr be)] + | EInj (Expr be) + +-- | Simple declarations +data SDecl be = + DVar (Name be) (SExpr be) + | DInst (Instance be) + +data Instance be = Instance { + instanceClass :: Global + , instanceType :: String + , instanceDecs :: [(Global, SExpr be)] + } + +{------------------------------------------------------------------------------- + Full backend +-------------------------------------------------------------------------------} + +class (BackendRep be, Monad (M be)) => Backend be where + data M be :: Type -> Type + + -- | Pick fresh variable + -- + -- This is scoped because variables don't need to be /globally/ unique. + fresh :: be -> String -> (Fresh be Bound -> M be a) -> M be a + +newtype Fresh be a = Fresh { getFresh :: Name be } diff --git a/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs new file mode 100644 index 00000000..1bb7522b --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/Common/Translation.hs @@ -0,0 +1,146 @@ +-- | Translation from the Haskell AST to the backend representation +module HsBindgen.Backend.Common.Translation (toBE) where + +import Data.Foldable +import Data.Kind +import Data.Vec.Lazy (Vec(..)) + +import HsBindgen.Backend.Common +import HsBindgen.Hs.AST qualified as Hs +import HsBindgen.Util.PHOAS + +{------------------------------------------------------------------------------- + Translate to backend-specific type +-------------------------------------------------------------------------------} + +class Backend be => ToBE be (a :: PHOAS) where + type Rep be a :: Type + type Rep be a = Expr be + + toBE :: be -> a (Fresh be) -> M be (Rep be a) + +class (ToBE be a, Rep be a ~ Expr be) => DefToBE be a +instance (ToBE be a, Rep be a ~ Expr be) => DefToBE be a + +{------------------------------------------------------------------------------- + Variable binding +-------------------------------------------------------------------------------} + +instance DefToBE be a => ToBE be (Hs.Lambda a) where + toBE be (Hs.Lambda k) = fresh be "x" $ \x -> + lambda be (Just x) <$> toBE be (k x) + +instance (DefToBE be a, DefToBE be b) => ToBE be (Hs.Ap a b) where + toBE be (Hs.Ap f stmts) = idiom' be <$> toBE be f <*> mapM (toBE be) stmts + +{------------------------------------------------------------------------------- + Declarations +-------------------------------------------------------------------------------} + +instance Backend be => ToBE be Hs.Decl where + type Rep be Hs.Decl = Decl be + toBE be (Hs.DeclInstance i) = inst be <$> toBE be i + +instance Backend be => ToBE be Hs.InstanceDecl where + type Rep be Hs.InstanceDecl = Instance be + toBE be (Hs.InstanceStorable i) = toBE be i + +{------------------------------------------------------------------------------- + 'Storable' +-------------------------------------------------------------------------------} + +instance Backend be => ToBE be (Hs.WithStruct Hs.StorableInstance) where + type Rep be (Hs.WithStruct Hs.StorableInstance) = Instance be + + toBE be (Hs.WithStruct struct Hs.StorableInstance{ + storableSizeOf + , storableAlignment + , storablePeek + , storablePoke + }) = do + peek <- toBE be storablePeek + poke <- toBE be storablePoke + return $ Instance { + instanceClass = Storable_Storable + , instanceType = Hs.structName struct + , instanceDecs = [ + (Storable_sizeOf , ELam Nothing $ EInt storableSizeOf) + , (Storable_alignment , ELam Nothing $ EInt storableAlignment) + , (Storable_peek , EInj peek) + , (Storable_poke , EInj poke) + ] + } + +instance Backend be => ToBE be Hs.PeekByteOff where + toBE be (Hs.PeekByteOff ptr i) = return . mkExpr be $ + appMany Storable_peekByteOff [EVar ptr, EInt i] + +instance Backend be => ToBE be Hs.PokeByteOff where + toBE be (Hs.PokeByteOff ptr i x) = return . mkExpr be $ + appMany Storable_pokeByteOff [EVar ptr, EInt i, EVar x] + +{------------------------------------------------------------------------------- + Statements +-------------------------------------------------------------------------------} + +instance DefToBE be a => ToBE be (Hs.Seq a) where + toBE be (Hs.Seq (List stmts)) = doAll be <$> mapM (toBE be) stmts + +{------------------------------------------------------------------------------- + Structs +-------------------------------------------------------------------------------} + +instance Backend be => ToBE be (Hs.IntroStruct n) where + toBE be (Hs.IntroStruct struct) = return $ + mkExpr be $ ECon $ Hs.structConstr struct + +instance DefToBE be a => ToBE be (Hs.ElimStruct n a) where + toBE be (Hs.ElimStruct struct k) = + fresh be "x" $ \x -> + freshVec be (Hs.structFields struct) $ \fs -> do + k' <- toBE be (k fs) + return $ mkExpr be $ ELam (Just x) $ ECase (EVar x) [ + (Hs.structConstr struct, toList fs, EInj k') + ] + +{------------------------------------------------------------------------------- + Internal auxiliary: derived functionality +-------------------------------------------------------------------------------} + +-- | Apply function to many arguments +appMany :: Global -> [SExpr be] -> SExpr be +appMany = foldl' EApp . EGlobal + +-- | Idiom brackets +idiom :: SExpr be -> [SExpr be] -> SExpr be +idiom f = foldl' (EInfix Applicative_seq) (EApp (EGlobal Applicative_pure) f) + +-- | Idiom brackets +idiom' :: forall be. Backend be => be -> Expr be -> [Expr be] -> Expr be +idiom' be f = mkExpr be . idiom (EInj f) . map EInj + +-- | Construct simple lambda abstraction +lambda :: Backend be => be -> Maybe (Fresh be Bound) -> Expr be -> Expr be +lambda be x = mkExpr be . ELam x . EInj + +-- | Simple instance declaration +inst :: Backend be => be -> Instance be -> Decl be +inst be i = mkDecl be $ DInst i + +-- | Monad sequencing +doAll :: Backend be => be -> [Expr be] -> Expr be +doAll _ [] = error "doAll: TODO: empty list" +doAll be ss = mkExpr be $ foldl1 (EInfix Monad_seq) (map EInj ss) + +freshVec :: + Backend be + => be + -> Vec n String + -> (Vec n (Fresh be Bound) -> M be a) + -> M be a +freshVec _ VNil k = k VNil +freshVec be (x ::: xs) k = fresh be x $ \v -> + freshVec be xs $ \vs -> + k (v ::: vs) + + diff --git a/hs-bindgen/src/HsBindgen/Backend/HsSrcExts.hs b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts.hs new file mode 100644 index 00000000..0ed3124f --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts.hs @@ -0,0 +1,156 @@ +module HsBindgen.Backend.HsSrcExts ( + BE(..) + -- * Backend monad + , M + , runM + , GenState(..) + -- * Annotations + , Ann -- opaque + , ann + ) where + +import Control.Monad.Reader +import Control.Monad.State +import Language.Haskell.Exts () +import Language.Haskell.Exts qualified as E + +import HsBindgen.Backend.Common + +{------------------------------------------------------------------------------- + Backend definition +-------------------------------------------------------------------------------} + +data BE = BE + +instance BackendRep BE where + type Name BE = E.QName Ann + type Expr BE = E.Exp Ann + type Decl BE = E.Decl Ann + + resolve _ = \case + Applicative_pure -> prelude "pure" + Applicative_seq -> prelude "<*>" + Monad_seq -> prelude ">>" + Storable_Storable -> foreignStorable "Storable" + Storable_sizeOf -> foreignStorable "sizeOf" + Storable_alignment -> foreignStorable "alignment" + Storable_peekByteOff -> foreignStorable "peekByteOff" + Storable_pokeByteOff -> foreignStorable "pokeByteOff" + Storable_peek -> foreignStorable "peek" + Storable_poke -> foreignStorable "poke" + + mkExpr be = \case + EGlobal n -> E.Var ann (resolve be n) + EVar x -> E.Var ann (getFresh x) + ECon n -> E.Con ann (unqualified n) + EInt i -> E.Lit ann (E.Int ann (fromIntegral i) (show i)) + EApp f x -> E.App ann (mkExpr be f) (mkExpr be x) + EInfix op x y -> E.InfixApp ann + (mkExpr be x) + (E.QVarOp ann $ resolve be op) + (mkExpr be y) + ELam x f -> E.Lambda ann + [ maybe + (E.PWildCard ann) + (E.PVar ann . unqual . getFresh) + x + ] + (mkExpr be f) + ECase x ms -> E.Case ann (mkExpr be x) [ + E.Alt ann + ( E.PApp ann (unqualified c) $ + map (E.PVar ann . unqual . getFresh) xs + ) + (E.UnGuardedRhs ann $ mkExpr be b) + Nothing + | (c, xs, b) <- ms + ] + EInj x -> x + + mkDecl be = \case + DVar x f -> simpleDecl x f + DInst i -> E.InstDecl ann Nothing + ( E.IRule ann Nothing Nothing $ + E.IHApp ann + (E.IHCon ann $ resolve be $ instanceClass i) + (E.TyCon ann $ unqualified $ instanceType i) + ) + ( Just . map (E.InsDecl ann) $ + map (\(x, f) -> simpleDecl (resolve be x) f) $ + instanceDecs i + ) + where + simpleDecl :: E.QName Ann -> SExpr BE -> E.Decl Ann + simpleDecl x f = + E.FunBind ann [ + E.Match ann (unqual x) [] + (E.UnGuardedRhs ann $ mkExpr be f) + Nothing + ] + +instance Backend BE where + newtype M BE a = Gen { unwrapGen :: ReaderT Int (State GenState) a } + deriving newtype ( + Functor + , Applicative + , Monad + , MonadState GenState + ) + + fresh _ = \x k -> withFreshName x $ k . Fresh . E.UnQual ann . E.Ident ann + +{------------------------------------------------------------------------------- + Generation state +-------------------------------------------------------------------------------} + +data GenState = GenState + +initGenState :: GenState +initGenState = GenState + +{------------------------------------------------------------------------------- + Monad functionality +-------------------------------------------------------------------------------} + +runM :: M BE a -> (a, GenState) +runM = flip runState initGenState . flip runReaderT 0 . unwrapGen + +withFreshName :: String -> (String -> M BE a) -> M BE a +withFreshName x k = Gen $ do + i <- ask + local succ $ unwrapGen (k (x ++ show i)) + +{------------------------------------------------------------------------------- + Syntax tree annotation + + Not sure if we'll need these. For now this is just a placeholder. +-------------------------------------------------------------------------------} + +-- | Syntax tree annotation +data Ann = Ann + deriving stock (Show) + +-- | Default annotation +ann :: Ann +ann = Ann + +{------------------------------------------------------------------------------- + Name resolution +-------------------------------------------------------------------------------} + +unqualified :: String -> E.QName Ann +unqualified = E.UnQual ann . E.Ident ann + +prelude :: String -> E.QName Ann +prelude = unqualified + +foreignStorable :: String -> E.QName Ann +foreignStorable = E.Qual ann (E.ModuleName ann "Foreign.Storable") . E.Ident ann + +{------------------------------------------------------------------------------- + Internal auxiliary: @haskell-src-exts@ +-------------------------------------------------------------------------------} + +unqual :: E.QName Ann -> E.Name Ann +unqual (E.UnQual _ n) = n +unqual n = error $ "unqual: unexpected " ++ show n diff --git a/hs-bindgen/src/HsBindgen/Hs/Render.hs b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Render.hs similarity index 91% rename from hs-bindgen/src/HsBindgen/Hs/Render.hs rename to hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Render.hs index d157ec56..47e583e4 100644 --- a/hs-bindgen/src/HsBindgen/Hs/Render.hs +++ b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Render.hs @@ -1,12 +1,10 @@ -- | Render generated Haskell code -- --- This is a thin layer on top of @haskell-src-exts@. --- -- Intended for qualified import. -- --- > import HsBindgen.Hs.Render (HsRenderOpts(..)) --- > import HsBindgen.Hs.Render qualified as Hs -module HsBindgen.Hs.Render ( +-- > import HsBindgen.Backend.HsSrcExts.Render (HsRenderOpts(..)) +-- > import HsBindgen.Backend.HsSrcExts.Render qualified as Backend.E +module HsBindgen.Backend.HsSrcExts.Render ( HsRenderOpts(..) , render , renderIO @@ -17,7 +15,7 @@ import Language.Haskell.Exts (Module) import Language.Haskell.Exts.Pretty qualified as Pretty import System.IO -import HsBindgen.Hs.Annotation (Ann) +import HsBindgen.Backend.HsSrcExts (Ann) {------------------------------------------------------------------------------- Options @@ -88,4 +86,4 @@ toMode _opts = Pretty.PPHsMode { -- TODO: -- For now we don't include @LINE@ pragmas. noLinePragmas :: Bool - noLinePragmas = False + noLinePragmas = False \ No newline at end of file diff --git a/hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Translation.hs new file mode 100644 index 00000000..2ed9edac --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/HsSrcExts/Translation.hs @@ -0,0 +1,54 @@ +module HsBindgen.Backend.HsSrcExts.Translation ( + HsModuleOpts(..) + , translate + ) where + +import Language.Haskell.Exts qualified as E + +import HsBindgen.Backend.Common.Translation +import HsBindgen.Backend.HsSrcExts +import HsBindgen.C.AST qualified as C +import HsBindgen.Translation.LowLevel + +{------------------------------------------------------------------------------- + Generate top-level module +-------------------------------------------------------------------------------} + +data HsModuleOpts = HsModuleOpts { + hsModuleName :: String + } + deriving (Show) + +translate :: HsModuleOpts -> C.Header -> E.Module Ann +translate opts header = + let (decls', _st) = runM $ mapM (toBE BE) (generateDeclarations header) + in E.Module + ann + (Just $ moduleHead opts) + [] -- No module pragmas + importDecls + decls' + +{------------------------------------------------------------------------------- + Module components +-------------------------------------------------------------------------------} + +moduleHead :: HsModuleOpts -> E.ModuleHead Ann +moduleHead opts = + E.ModuleHead + ann + (moduleName opts) + Nothing -- No warning text (the module is not deprecated) + exportList + +moduleName :: HsModuleOpts -> E.ModuleName Ann +moduleName = E.ModuleName ann . hsModuleName + +-- TODO: +-- Generate export list. For now we just export everything. +exportList :: Maybe (E.ExportSpecList Ann) +exportList = Nothing + +importDecls :: [E.ImportDecl Ann] +importDecls = [] + diff --git a/hs-bindgen/src/HsBindgen/Backend/TH.hs b/hs-bindgen/src/HsBindgen/Backend/TH.hs new file mode 100644 index 00000000..8dfa22d3 --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/TH.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module HsBindgen.Backend.TH ( + BE(..) + , M + , runM + ) where + +import Foreign.Storable qualified +import Language.Haskell.TH (Q) +import Language.Haskell.TH qualified as TH + +import HsBindgen.Backend.Common + +{------------------------------------------------------------------------------- + Backend definition +-------------------------------------------------------------------------------} + +data BE = BE + +instance BackendRep BE where + type Name BE = TH.Name + type Expr BE = TH.ExpQ + type Decl BE = TH.DecQ + + resolve _ = \case + Applicative_pure -> 'pure + Applicative_seq -> '(<*>) + Monad_seq -> '(>>) + Storable_Storable -> ''Foreign.Storable.Storable + Storable_sizeOf -> 'Foreign.Storable.sizeOf + Storable_alignment -> 'Foreign.Storable.alignment + Storable_peekByteOff -> 'Foreign.Storable.peekByteOff + Storable_pokeByteOff -> 'Foreign.Storable.pokeByteOff + Storable_peek -> 'Foreign.Storable.peek + Storable_poke -> 'Foreign.Storable.poke + + mkExpr be = \case + EGlobal n -> TH.varE (resolve be n) + EVar x -> TH.varE (getFresh x) + ECon n -> TH.conE (TH.mkName n) + EInt i -> TH.litE (TH.IntegerL $ fromIntegral i) + EApp f x -> TH.appE (mkExpr be f) (mkExpr be x) + EInfix op x y -> TH.infixE + (Just $ mkExpr be x) + (TH.varE $ resolve be op) + (Just $ mkExpr be y) + ELam x f -> TH.lamE + [maybe TH.wildP (TH.varP . getFresh) x] + (mkExpr be f) + ECase x ms -> TH.caseE (mkExpr be x) [ + TH.match + ( TH.conP (TH.mkName c) $ + map (TH.varP . getFresh) xs + ) + (TH.normalB $ mkExpr be b) + [] + | (c, xs, b) <- ms + ] + EInj x -> x + + mkDecl be = \case + DVar x f -> simpleDecl x f + DInst i -> TH.instanceD + (return []) + [t| $(TH.conT $ resolve be $ instanceClass i) + $(TH.conT $ TH.mkName $ instanceType i) + |] + ( map (\(x, f) -> simpleDecl (resolve be x) f) $ + instanceDecs i + ) + where + simpleDecl :: TH.Name -> SExpr BE -> TH.DecQ + simpleDecl x f = TH.valD (TH.varP x) (TH.normalB $ mkExpr be f) [] + +instance Backend BE where + newtype M BE a = Gen { unwrapGen :: Q a } + deriving newtype ( + Functor + , Applicative + , Monad + , TH.Quote + ) + + fresh _ = \x k -> TH.newName x >>= k . Fresh + +{------------------------------------------------------------------------------- + Monad functionality +-------------------------------------------------------------------------------} + +runM :: M BE a -> Q a +runM = unwrapGen diff --git a/hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs new file mode 100644 index 00000000..8bf897b9 --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs @@ -0,0 +1,29 @@ +module HsBindgen.Backend.TH.Translation ( + translateC + , translateHs + ) where + +import Language.Haskell.TH (Q) +import Language.Haskell.TH qualified as TH + +import HsBindgen.Backend.Common +import HsBindgen.Backend.Common.Translation +import HsBindgen.Backend.TH +import HsBindgen.C.AST qualified as C +import HsBindgen.Hs.AST qualified as Hs +import HsBindgen.Translation.LowLevel + +{------------------------------------------------------------------------------- + Generate list of declarations for splicing +-------------------------------------------------------------------------------} + +translateC :: C.Header -> TH.DecsQ +translateC = translateHs . generateDeclarations + +translateHs :: [Hs.Decl (Fresh BE)] -> TH.DecsQ +translateHs = + aux . runM . mapM (toBE BE) + where + aux :: Q [TH.DecQ] -> TH.DecsQ + aux = (>>= sequence) + diff --git a/hs-bindgen/src/HsBindgen/C/AST.hs b/hs-bindgen/src/HsBindgen/C/AST.hs index 79e6b6d0..48dc031d 100644 --- a/hs-bindgen/src/HsBindgen/C/AST.hs +++ b/hs-bindgen/src/HsBindgen/C/AST.hs @@ -64,8 +64,9 @@ data Struct = Struct { deriving anyclass (PrettyVal) data StructField = StructField { - fieldName :: String - , fieldType :: PrimType + fieldName :: String + , fieldOffset :: Int + , fieldType :: PrimType } deriving stock (Show, Eq, Generic) deriving anyclass (PrettyVal) diff --git a/hs-bindgen/src/HsBindgen/C/Parser.hs b/hs-bindgen/src/HsBindgen/C/Parser.hs index bb7ab0b9..20fd202b 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser.hs +++ b/hs-bindgen/src/HsBindgen/C/Parser.hs @@ -156,8 +156,9 @@ foldStructFields tracer _parent current = do typeKind <- cxtKind <$> clang_getCursorType current case primType typeKind of Just fieldType -> do - fieldName <- decodeString <$> clang_getCursorDisplayName current - let field = C.StructField{fieldName, fieldType} + fieldOffset <- fromIntegral <$> clang_Cursor_getOffsetOfField current + fieldName <- decodeString <$> clang_getCursorDisplayName current + let field = C.StructField{fieldName, fieldOffset, fieldType} return $ Continue (Just field) _otherwise -> do traceWith tracer Warning $ unrecognizedType typeKind diff --git a/hs-bindgen/src/HsBindgen/Hs/AST.hs b/hs-bindgen/src/HsBindgen/Hs/AST.hs new file mode 100644 index 00000000..ed1b6e7d --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Hs/AST.hs @@ -0,0 +1,198 @@ +-- | Haskell AST +-- +-- Abstract Haskell syntax for the specific purposes of hs-bindgen: we only +-- cover the parts of the Haskell syntax that we need. We attempt to do this in +-- such a way that the generated Haskell code is type correct by construction. +-- We use PHOAS for bound variables: the individual backends (TH, standalone) +-- are responsible for generating fresh variable names. +-- +-- TODO: +-- We should annotate the AST with to explain tool decisions (when generating +-- high-level API). +-- +-- TODO: +-- We should annotate the AST with the relevant part of the C header here +-- (including line numbers). +-- +-- Intended for qualified import: +-- +-- > import HsBindgen.Hs.AST qualified as Hs +module HsBindgen.Hs.AST ( + -- * Information about generated code + Struct(..) + -- * Variable binding + , Lambda(..) + , Ap(..) + -- * Declarations + , Decl(..) + , InstanceDecl(..) + -- ** 'Storable' + , StorableInstance(..) + , PeekByteOff(..) + , PokeByteOff(..) + -- ** Statements + , Seq(..) + -- ** Structs + , WithStruct(..) + , IntroStruct(..) + , ElimStruct(..) + ) where + +import Data.Nat +import Data.Type.Nat +import Data.Vec.Lazy (Vec(..)) +import Generics.SOP qualified as SOP +import GHC.Generics qualified as GHC +import GHC.Show (appPrec1) + +import HsBindgen.Util.PHOAS + +{------------------------------------------------------------------------------- + Information about generated code +-------------------------------------------------------------------------------} + +data Struct (n :: Nat) = Struct { + structName :: String + , structConstr :: String + , structFields :: Vec n String + } + +deriving stock instance Show (Struct n) + +{------------------------------------------------------------------------------- + Variable binding +-------------------------------------------------------------------------------} + +-- | Lambda abstraction +type Lambda :: PHOAS -> PHOAS +data Lambda a f = Lambda (f Bound -> a f) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- | Applicative structure +type Ap :: PHOAS -> PHOAS -> PHOAS +data Ap a b f = Ap (b f) [a f] + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +{------------------------------------------------------------------------------- + Declarations +-------------------------------------------------------------------------------} + +-- | Top-level declaration +type Decl :: PHOAS +data Decl f = + DeclInstance (InstanceDecl f) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- | Class instance declaration +type InstanceDecl :: PHOAS +data InstanceDecl f = + InstanceStorable (WithStruct StorableInstance f) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +{------------------------------------------------------------------------------- + 'Storable' +-------------------------------------------------------------------------------} + +-- | 'Storable' instance +-- +-- Currently this models storable instances for structs /only/. +-- +-- +type StorableInstance :: Nat -> PHOAS +data StorableInstance n f where + StorableInstance :: + { storableSizeOf :: Int + , storableAlignment :: Int + , storablePeek :: Lambda (Ap PeekByteOff (IntroStruct n)) f + , storablePoke :: Lambda (ElimStruct n (Seq PokeByteOff)) f + } + -> StorableInstance n f + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- | Call to 'peekByteOff' +-- +-- +type PeekByteOff :: PHOAS +data PeekByteOff f = PeekByteOff (f Bound) Int + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- | Call to 'pokeByteOff' +-- +-- +type PokeByteOff :: PHOAS +data PokeByteOff f = PokeByteOff (f Bound) Int (f Bound) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +{------------------------------------------------------------------------------- + Statements +-------------------------------------------------------------------------------} + +-- | Simple sequential composition (no bindings) +type Seq :: PHOAS -> PHOAS +newtype Seq a f = Seq (List a f) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +{------------------------------------------------------------------------------- + Structs +-------------------------------------------------------------------------------} + +type WithStruct :: (Nat -> PHOAS) -> PHOAS +data WithStruct a f where + WithStruct :: SNatI n => Struct n -> a n f -> WithStruct a f + +-- | Construct value of a struct +type IntroStruct :: Nat -> PHOAS +data IntroStruct n f = IntroStruct (Struct n) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- | Lambda-case for a struct +type ElimStruct :: Nat -> PHOAS -> PHOAS +data ElimStruct n a f = ElimStruct (Struct n) (Vec n (f Bound) -> a f) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +{------------------------------------------------------------------------------- + Show instances + + These generate valid Haskell code. +-------------------------------------------------------------------------------} + +deriving anyclass instance ShowOpen (Decl Unique) +deriving anyclass instance ShowOpen (InstanceDecl Unique) +deriving anyclass instance ShowOpen (PeekByteOff Unique) +deriving anyclass instance ShowOpen (PokeByteOff Unique) + +deriving anyclass instance SNatI n => ShowOpen (IntroStruct n Unique) +deriving anyclass instance SNatI n => ShowOpen (StorableInstance n Unique) + +deriving anyclass instance ShowOpen (a Unique) => ShowOpen (Lambda a Unique) +deriving anyclass instance ShowOpen (a Unique) => ShowOpen (Seq a Unique) + +deriving anyclass instance + (ShowOpen (a Unique), ShowOpen (b Unique)) + => ShowOpen (Ap a b Unique) + +deriving anyclass instance + (ShowOpen (a Unique), SNatI n) + => ShowOpen (ElimStruct n a Unique) + +deriving via Degenerate (Struct n) instance ShowOpen (Struct n) + +-- Handwritten instance (generics don't play nice with existentials) +instance + (forall n. SNatI n => ShowOpen (a n Unique)) + => ShowOpen (WithStruct a Unique) where + showOpen u p (WithStruct struct a) = showParen (p >= appPrec1) $ + showString "WithStruct " + . showOpen u appPrec1 struct + . showString " " + . showOpen u appPrec1 a diff --git a/hs-bindgen/src/HsBindgen/Hs/Annotation.hs b/hs-bindgen/src/HsBindgen/Hs/Annotation.hs deleted file mode 100644 index a1b048ae..00000000 --- a/hs-bindgen/src/HsBindgen/Hs/Annotation.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Syntax tree annotations --- --- The type argument @l@ pervasive in @haskell-src-exts@ allows for arbitrary --- annotations; we will instantiate it to 'Ann', defined in this module. This --- type is not considered part of the public API of @hs-bindgen@. --- --- TODO: --- If we want to include LINE pragmas, we will need to include line information --- (referring to the C header) in these annotations. --- --- Intended for qualified import. --- --- > import HsBindgen.Hs.Annotation (Ann, noAnn) --- > import HsBindgen.Hs.Annotation qualified as Ann -module HsBindgen.Hs.Annotation ( - Ann(..) - , noAnn - ) where - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - --- | Syntax tree annotation --- --- TODO: --- We should use this explain tool decisions (when generating high-level API). --- --- TODO: --- We should reference the relevant part of the C header here (including line --- numbers). -data Ann = Ann { - } - -noAnn :: Ann -noAnn = Ann diff --git a/hs-bindgen/src/HsBindgen/Lib.hs b/hs-bindgen/src/HsBindgen/Lib.hs index 2ef7c74d..72d9f4bf 100644 --- a/hs-bindgen/src/HsBindgen/Lib.hs +++ b/hs-bindgen/src/HsBindgen/Lib.hs @@ -40,6 +40,7 @@ module HsBindgen.Lib ( , getClangAST , getComments , getTargetTriple + , genHaskell -- * Logging , Tracer @@ -49,25 +50,28 @@ module HsBindgen.Lib ( , mkTracerIO ) where -import Data.Tree (Forest) import Data.ByteString (ByteString) +import Data.Tree (Forest) import GHC.Generics (Generic) -import Language.Haskell.Exts qualified as Hs -import Language.Haskell.Meta qualified as Meta +import Language.Haskell.Exts qualified as E import Language.Haskell.TH qualified as TH import Text.Show.Pretty qualified as Pretty +import HsBindgen.Backend.HsSrcExts (Ann) +import HsBindgen.Backend.HsSrcExts.Render (HsRenderOpts(..)) +import HsBindgen.Backend.HsSrcExts.Render qualified as Backend.E +import HsBindgen.Backend.HsSrcExts.Translation (HsModuleOpts(..)) +import HsBindgen.Backend.HsSrcExts.Translation qualified as Backend.E +import HsBindgen.Backend.TH.Translation qualified as Backend.TH import HsBindgen.C.AST qualified as C import HsBindgen.C.Parser (ParseMsg, Element(..)) import HsBindgen.C.Parser qualified as C import HsBindgen.C.Predicate (Predicate(..)) import HsBindgen.Clang.Args -import HsBindgen.Hs.Annotation -import HsBindgen.Hs.Render (HsRenderOpts(..)) -import HsBindgen.Hs.Render qualified as Hs -import HsBindgen.Translation.LowLevel -import HsBindgen.Util.Tracer import HsBindgen.Clang.Util.SourceLoc +import HsBindgen.Hs.AST qualified as Hs +import HsBindgen.Translation.LowLevel qualified as LowLevel +import HsBindgen.Util.Tracer {------------------------------------------------------------------------------- Type aliases @@ -82,7 +86,7 @@ newtype CHeader = WrapCHeader { deriving (Eq, Generic) newtype HsModule = WrapHsModule { - unwrapHsModule :: Hs.Module Ann + unwrapHsModule :: E.Module Ann } {------------------------------------------------------------------------------- @@ -113,10 +117,10 @@ parseCHeader tracer p args fp = -------------------------------------------------------------------------------} genModule :: HsModuleOpts -> CHeader -> HsModule -genModule opts = WrapHsModule . generateModule opts . unwrapCHeader +genModule opts = WrapHsModule . Backend.E.translate opts . unwrapCHeader -genDecls :: CHeader -> [TH.Dec] -genDecls = map Meta.toDec . generateDeclarations . C.headerDecls . unwrapCHeader +genDecls :: CHeader -> TH.DecsQ +genDecls = Backend.TH.translateC . unwrapCHeader {------------------------------------------------------------------------------- Processing output @@ -129,7 +133,7 @@ prettyC :: CHeader -> IO () prettyC = Pretty.dumpIO . unwrapCHeader prettyHs :: HsRenderOpts -> Maybe FilePath -> HsModule -> IO () -prettyHs opts fp = Hs.renderIO opts fp . unwrapHsModule +prettyHs opts fp = Backend.E.renderIO opts fp . unwrapHsModule {------------------------------------------------------------------------------- Common pipelines @@ -141,7 +145,7 @@ preprocess :: -> ClangArgs -- ^ @libclang@ options -> FilePath -- ^ Path to the C header -> HsModuleOpts -- ^ Options for the Haskell module generation - -> Hs.HsRenderOpts -- ^ Options for rendering the generated Haskell code + -> HsRenderOpts -- ^ Options for rendering the generated Haskell code -> Maybe FilePath -- ^ Name of the Haskell file (none for @stdout@) -> IO () preprocess tracer p clangArgs inp modOpts renderOpts out = do @@ -178,3 +182,9 @@ getTargetTriple :: ClangArgs -> FilePath -> IO ByteString getTargetTriple args fp = C.withTranslationUnit args fp $ C.getTranslationUnitTargetTriple + +-- | Generate our internal Haskell representation of the translated C header +genHaskell :: CHeader -> [Hs.Decl f] +genHaskell = LowLevel.generateDeclarations . unwrapCHeader + + diff --git a/hs-bindgen/src/HsBindgen/TH.hs b/hs-bindgen/src/HsBindgen/TH.hs index 43c9167d..685d492e 100644 --- a/hs-bindgen/src/HsBindgen/TH.hs +++ b/hs-bindgen/src/HsBindgen/TH.hs @@ -12,8 +12,9 @@ import HsBindgen.Util.Tracer -- TODO: -- We need to think about how we want to handle configuration in TH mode. generateBindingsFor :: FilePath -> Q [Dec] -generateBindingsFor fp = liftIO $ - genDecls <$> parseCHeader tracer p args fp +generateBindingsFor fp = do + cHeader <- liftIO $ parseCHeader tracer p args fp + genDecls cHeader where tracer :: Tracer IO ParseMsg tracer = contramap prettyLogMsg $ mkTracerQ False diff --git a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs index 0cb624e2..c652f012 100644 --- a/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs +++ b/hs-bindgen/src/HsBindgen/Translation/LowLevel.hs @@ -6,63 +6,92 @@ -- -- * Milestone 2: Low-level API -- -module HsBindgen.Translation.LowLevel ( - HsModuleOpts(..) - , generateModule - , generateDeclarations - ) where +module HsBindgen.Translation.LowLevel (generateDeclarations) where -import Language.Haskell.Exts qualified as Hs +import Data.Foldable +import Data.Kind +import Data.Maybe +import Data.Type.Nat +import Data.Vec.Lazy (Vec) +import Data.Vec.Lazy qualified as Vec import HsBindgen.C.AST qualified as C -import HsBindgen.Hs.Annotation --- import HsBindgen.Spec +import HsBindgen.Hs.AST qualified as Hs +import HsBindgen.Util.PHOAS {------------------------------------------------------------------------------- - Configuration + Top-level -------------------------------------------------------------------------------} -data HsModuleOpts = HsModuleOpts { - hsModuleName :: String - } - deriving (Show) +generateDeclarations :: C.Header -> [Hs.Decl f] +generateDeclarations = getList . toHs {------------------------------------------------------------------------------- - Top-level + Translation -------------------------------------------------------------------------------} --- TODO: -generateModule :: HsModuleOpts -> C.Header -> Hs.Module Ann -generateModule opts (C.Header decls) = - Hs.Module - noAnn - (Just $ moduleHead opts) - [] -- No module pragmas - importDecls - (generateDeclarations decls) +class ToHs (a :: Type) where + type InHs a :: PHOAS + toHs :: a -> InHs a f -generateDeclarations :: [C.Decl] -> [Hs.Decl Ann] -generateDeclarations _decls = [] +instance ToHs C.Header where + type InHs C.Header = List Hs.Decl + toHs (C.Header decs) = List $ concatMap getList (map toHs decs) + +instance ToHs C.Decl where + type InHs C.Decl = List Hs.Decl + toHs (C.DeclStruct struct) = reifyStructFields struct $ structDecs struct + toHs _otherwise = List [] -- TODO {------------------------------------------------------------------------------- - Module components + Structs -------------------------------------------------------------------------------} -moduleHead :: HsModuleOpts -> Hs.ModuleHead Ann -moduleHead opts = - Hs.ModuleHead - noAnn - (moduleName opts) - Nothing -- No warning text (the module is not deprecated) - exportList +reifyStructFields :: + C.Struct + -> (forall n. SNatI n => Vec n C.StructField -> a) + -> a +reifyStructFields struct k = Vec.reifyList (C.structFields struct) k + +-- | Generate declarations for given C struct +-- +-- This is just a first sketch so far. +-- +-- TODO: +-- +-- * We currently generate only the 'Storable' instance. We should also +-- generate the @data@ declaration. +-- * Name mangling +-- * Deal with untagged structs. +-- * .. +structDecs :: forall n f. + SNatI n + => C.Struct -> Vec n C.StructField -> List Hs.Decl f +structDecs struct fields = List [ + Hs.DeclInstance $ Hs.InstanceStorable storable + ] + where + hs :: Hs.Struct n + hs = Hs.Struct { + structName = fromMaybe "X" (C.structTag struct) + , structConstr = maybe "MkX" ("Mk" ++) (C.structTag struct) + , structFields = Vec.map C.fieldName fields + } -moduleName :: HsModuleOpts -> Hs.ModuleName Ann -moduleName = Hs.ModuleName noAnn . hsModuleName + storable :: Hs.WithStruct Hs.StorableInstance f + storable = Hs.WithStruct hs $ Hs.StorableInstance { + Hs.storableSizeOf = C.structSizeof struct + , Hs.storableAlignment = C.structAlignment struct + , Hs.storablePeek = Hs.Lambda $ \ptr -> + Hs.Ap (Hs.IntroStruct hs) $ + map (peek ptr) (C.structFields struct) + , Hs.storablePoke = Hs.Lambda $ \ptr -> + Hs.ElimStruct hs $ \xs -> Hs.Seq . List $ + toList $ Vec.zipWith (poke ptr) fields xs + } --- TODO: --- Generate export list. For now we just export everything. -exportList :: Maybe (Hs.ExportSpecList Ann) -exportList = Nothing + peek :: f Bound -> C.StructField -> Hs.PeekByteOff f + peek ptr f = Hs.PeekByteOff ptr (C.fieldOffset f) -importDecls :: [Hs.ImportDecl Ann] -importDecls = [] + poke :: f Bound -> C.StructField -> f Bound -> Hs.PokeByteOff f + poke ptr f i = Hs.PokeByteOff ptr (C.fieldOffset f) i diff --git a/hs-bindgen/src/HsBindgen/Util/PHOAS.hs b/hs-bindgen/src/HsBindgen/Util/PHOAS.hs new file mode 100644 index 00000000..ea2a68e0 --- /dev/null +++ b/hs-bindgen/src/HsBindgen/Util/PHOAS.hs @@ -0,0 +1,164 @@ +-- | Our particular flavour of PHOAS +-- +-- Intended for unqualified import. +module HsBindgen.Util.PHOAS ( + -- * Main definitions + PHOAS + , Bound + -- * Lifted types + , List(..) + -- * Showing PHOAS types + , Unique(..) + , ShowOpen(..) + , showClosed + -- * Deriving-via support + , Degenerate(..) + ) where + +import Data.Fin qualified as Fin +import Data.Kind +import Data.List (intersperse) +import Data.Type.Nat +import Data.Vec.Lazy (Vec(..)) +import Data.Vec.Lazy qualified as Vec +import Generics.SOP +import GHC.Generics qualified as GHC +import GHC.Show +import Data.Foldable + +{------------------------------------------------------------------------------- + Main definitions +-------------------------------------------------------------------------------} + +type PHOAS = (Type -> Type) -> Type + +-- | Bound name +data Bound + +{------------------------------------------------------------------------------- + Lifted types +-------------------------------------------------------------------------------} + +type List :: PHOAS -> PHOAS +newtype List a f = List { getList :: [a f] } + deriving stock (GHC.Generic) + deriving anyclass (Generic, HasDatatypeInfo) + +deriving anyclass instance ShowOpen (a Unique) => ShowOpen (List a Unique) + +{------------------------------------------------------------------------------- + Showing PHOAS types +-------------------------------------------------------------------------------} + +newtype Unique a = Unique Int + deriving newtype (Enum) + +showUnique :: Unique a -> ShowS +showUnique (Unique u) = showString "x" . showsPrec 0 u + +class ShowOpen (term :: Type) where + -- | Show open term + -- + -- Precondition: all bound variables already present in the term must be + -- strictly less than the specified next available 'Unique'. + showOpen :: Unique Bound -> Int -> term -> ShowS + + default showOpen :: + (HasDatatypeInfo term, All2 ShowOpen (Code term)) + => Unique Bound -> Int -> term -> ShowS + showOpen u p term = + gshowOpen u p + (constructorInfo (datatypeInfo (Proxy @term))) + (from term) + +instance ShowOpen (Unique Bound) where + showOpen _ _ = showUnique + +instance ShowOpen (a Unique) => ShowOpen (Unique Bound -> a Unique) where + showOpen u p f = showParen (p >= appPrec1) $ + showString "\\" + . showUnique u + . showString " -> " + . showOpen (succ u) 0 (f u) + +instance ( ShowOpen (a Unique) + , SNatI n + ) => ShowOpen (Vec n (Unique Bound) -> a Unique) where + showOpen (Unique u) p f = showParen (p >= appPrec1) $ + showString "\\(" + . intercalateS (showString " ::: ") (map showUnique $ toList newUniques) + . showString " ::: VNil) -> " + . showOpen (Unique $ u + Vec.length newUniques) p (f newUniques) + where + newUniques :: Vec n (Unique Bound) + newUniques = Vec.tabulate $ \n -> + Unique (u + fromIntegral (Fin.toInteger n)) + +instance ShowOpen a => ShowOpen [a] where + showOpen u _p xs = + showString "[" + . intercalateS (showString ", ") xs' + . showString "]" + where + xs' :: [ShowS] + xs' = map (showOpen u 0) xs + +-- | Show closed PHOAS term +showClosed :: forall a. ShowOpen (a Unique) => (forall f. a f) -> String +showClosed term = showOpen (Unique 0) 0 (term :: a Unique) "" + +{------------------------------------------------------------------------------- + Generic 'ShowOpen' + + This is based on "Generis.SOP.Show" from @basic-sop@. +-------------------------------------------------------------------------------} + +gshowOpen :: + All2 ShowOpen xss + => Unique Bound -> Int -> NP ConstructorInfo xss -> SOP I xss -> ShowS +gshowOpen u p cs (SOP sop) = + hcollapse $ hcliftA2 (Proxy @(All ShowOpen)) (gshowConstr u p) cs sop + +gshowConstr :: + All ShowOpen xs + => Unique Bound -> Int -> ConstructorInfo xs -> NP I xs -> K ShowS xs +gshowConstr u p (Constructor n) args = K $ showParen (p >= appPrec1) $ + intercalateS (showString " ") (showString n : args') + where + args' :: [ShowS] + args' = hcollapse $ + hcliftA (Proxy @ShowOpen) (K . showOpen u appPrec1 . unI) args +gshowConstr u p (Record n ns) args = K $ showParen (p >= appPrec1) $ + showString n + . showString " {" + . intercalateS (showString ", ") args' + . showString "}" + where + args' :: [ShowS] + args' = hcollapse $ hcliftA2 (Proxy @ShowOpen) (gshowField u) ns args +gshowConstr _ _ Infix{} _ = + error "gshowConstr: TODO: Infix" + +gshowField :: ShowOpen a => Unique Bound -> FieldInfo a -> I a -> K ShowS a +gshowField u (FieldInfo field) (I x) = K $ + showString field + . showString " = " + . showOpen u 0 x + +{------------------------------------------------------------------------------- + Degenerate 'ShowOpen' instances +-------------------------------------------------------------------------------} + +newtype Degenerate a = Degenerate a + +instance Show a => ShowOpen (Degenerate a) where + showOpen _ p (Degenerate x) = showsPrec p x + +deriving via Degenerate Int instance ShowOpen Int + +{------------------------------------------------------------------------------- + Auxiliary: ShowS +-------------------------------------------------------------------------------} + +intercalateS :: ShowS -> [ShowS] -> ShowS +intercalateS sep = foldr (.) id . intersperse sep \ No newline at end of file diff --git a/hs-bindgen/test-th/HsBindgen/TestTH/Examples.hs b/hs-bindgen/test-th/HsBindgen/TestTH/Examples.hs new file mode 100644 index 00000000..b4f9eb59 --- /dev/null +++ b/hs-bindgen/test-th/HsBindgen/TestTH/Examples.hs @@ -0,0 +1,58 @@ +module HsBindgen.TestTH.Examples ( + MyStruct(..) + , decls + ) where + +import Data.Int +import Data.Nat +import Data.Vec.Lazy (Vec(..)) + +import HsBindgen.Hs.AST qualified as Hs +import HsBindgen.Util.PHOAS + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +data MyStruct = MkMyStruct { + myStructField1 :: Int32 + , myStructField2 :: Int32 + } + +{------------------------------------------------------------------------------- + Top-level +-------------------------------------------------------------------------------} + +decls :: [Hs.Decl f] +decls = [ + Hs.DeclInstance $ Hs.InstanceStorable myStructStorableInstance + ] + +{------------------------------------------------------------------------------- + Declarations +-------------------------------------------------------------------------------} + +myStruct :: Hs.Struct ('S ('S 'Z)) +myStruct = Hs.Struct { + structName = "MyStruct" + , structConstr = "MkMyStruct" + , structFields = "myStructField1" ::: "myStructField2" ::: VNil + } + +myStructStorableInstance :: Hs.WithStruct Hs.StorableInstance f +myStructStorableInstance = Hs.WithStruct myStruct $ + Hs.StorableInstance { + storableSizeOf = 8 + , storableAlignment = 8 + + , storablePeek = Hs.Lambda $ \ptr -> + Hs.Ap (Hs.IntroStruct myStruct) [ + Hs.PeekByteOff ptr 0 + , Hs.PeekByteOff ptr 4 + ] + , storablePoke = Hs.Lambda $ \ptr -> + Hs.ElimStruct myStruct $ \(f1 ::: f2 ::: VNil) -> Hs.Seq . List $ [ + Hs.PokeByteOff ptr 0 f1 + , Hs.PokeByteOff ptr 4 f2 + ] + } diff --git a/hs-bindgen/test-th/HsBindgen/TestTH/Spliced.hs b/hs-bindgen/test-th/HsBindgen/TestTH/Spliced.hs new file mode 100644 index 00000000..39a275dd --- /dev/null +++ b/hs-bindgen/test-th/HsBindgen/TestTH/Spliced.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans -ddump-splices -ddump-to-file #-} + +{-# LANGUAGE TemplateHaskell #-} + +module HsBindgen.TestTH.Spliced where + +import HsBindgen.Backend.TH.Translation +import HsBindgen.TestTH.Examples + +translateHs decls \ No newline at end of file diff --git a/hs-bindgen/test-th/TestTH.hs b/hs-bindgen/test-th/TestTH.hs new file mode 100644 index 00000000..23be1789 --- /dev/null +++ b/hs-bindgen/test-th/TestTH.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Main (main) where + +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "test-th" [ + ] + diff --git a/hs-bindgen/tests/golden.hs b/hs-bindgen/tests/golden.hs index 26d1a11b..6c637c43 100644 --- a/hs-bindgen/tests/golden.hs +++ b/hs-bindgen/tests/golden.hs @@ -3,19 +3,20 @@ module Main (main) where import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Tree (Tree (..)) +import Data.TreeDiff.Golden (ediffGolden) import System.Directory (doesFileExist, setCurrentDirectory) import System.FilePath ((), (-<.>)) import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.Golden (goldenVsStringDiff) import Test.Tasty.Golden.Advanced (goldenTest) -import Language.Haskell.TH.Ppr (ppr) -import Data.TreeDiff.Golden (ediffGolden) +import Test.Tasty.HUnit (testCase, (@?=)) import Orphans () import HsBindgen.Clang.Util.Classification +import HsBindgen.Hs.AST qualified as Hs import HsBindgen.Lib +import HsBindgen.Util.PHOAS main :: IO () main = do @@ -43,7 +44,7 @@ main = do golden name = testGroup name [ goldenDump name , goldenTreeDiff name - , goldenTH name + , goldenHs name ] goldenDump name = goldenVsStringDiff "ast" diff ("fixtures" (name ++ ".dump.txt")) $ do @@ -63,16 +64,17 @@ main = do header <- parseCHeader nullTracer SelectFromMainFile args fp return header - goldenTH name = goldenVsStringDiff "th" diff ("fixtures" (name ++ ".th.txt")) $ do + goldenHs name = goldenVsStringDiff "hs" diff ("fixtures" (name ++ ".hs")) $ do -- -<.> does weird stuff for filenames with multiple dots; -- I usually simply avoid using it. let fp = "examples" (name ++ ".h") args = ["-target", "x86_64-pc-linux-gnu"] header <- parseCHeader nullTracer SelectFromMainFile args fp - let decls = genDecls header + let decls :: forall f. List Hs.Decl f + decls = List $ genHaskell header - return $ LBS8.pack $ unlines $ map (show . ppr) decls + return $ LBS8.pack $ showClosed decls treeToLines :: Tree Element -> [String] treeToLines tree = go 0 tree [] where