Merge pull request #157 from well-typed/edsko/haskell-ast

Haskell AST

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

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.
+--
+-- <https://clang.llvm.org/doxygen/group__CINDEX__TYPES.html#gaa7e0f0ec320c645e971168ac39aa0cab>
+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.
 --

hs-bindgen/fixtures/enums.hs

@@ -0,0 +1 @@
+List {getList = []}

hs-bindgen/fixtures/macro_functions.hs

@@ -0,0 +1 @@
+List {getList = []}

hs-bindgen/fixtures/macros.hs

@@ -0,0 +1 @@
+List {getList = []}

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

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 {

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

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

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

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

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
+
+

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 }