Support typed folds over the Clang AST

hs-bindgen-patterns/hs-bindgen-patterns.cabal

@@ -34,9 +34,8 @@ library
   exposed-modules:
       HsBindgen.Patterns
   other-modules:
+      HsBindgen.Patterns.Backtrace
       HsBindgen.Patterns.Enum.Bitfield
       HsBindgen.Patterns.Enum.Simple
-      HsBindgen.Patterns.SafeForeignPtr
-      HsBindgen.Patterns.Stack
   hs-source-dirs:
       src

hs-bindgen-patterns/src/HsBindgen/Patterns.hs

@@ -21,21 +21,13 @@ module HsBindgen.Patterns (
   , bitfieldEnum
   , fromBitfieldEnum
   , flagIsSet
-    -- * Foreign pointers
-  , SafeForeignPtr
-  , AccessedFinalizedForeignPtrException
-    -- ** API
-  , newSafeForeignPtr
-  , withSafeForeignPtr
-  , finalizeSafeForeignPtr
     -- * Backtrace
-  , Stack
-  , getStack
-  , prettyStack
-  , ContainsStack(..)
+  , Backtrace
+  , collectBacktrace
+  , prettyBacktrace
+  , CollectedBacktrace(..)
   ) where
 
+import HsBindgen.Patterns.Backtrace
 import HsBindgen.Patterns.Enum.Bitfield
 import HsBindgen.Patterns.Enum.Simple
-import HsBindgen.Patterns.SafeForeignPtr
-import HsBindgen.Patterns.Stack

hs-bindgen-patterns/src/HsBindgen/Patterns/Stack.hs → hs-bindgen-patterns/src/HsBindgen/Patterns/Backtrace.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE CPP #-}
 
--- | Shim to provide stack support
-module HsBindgen.Patterns.Stack (
-    Stack
-  , prettyStack
-  , getStack
-  , ContainsStack(..)
+-- | Shim to provide backtrace support
+module HsBindgen.Patterns.Backtrace (
+    Backtrace
+  , prettyBacktrace
+  , collectBacktrace
+  , CollectedBacktrace(..)
   ) where
 
 import Control.Exception
@@ -24,35 +24,35 @@ import Control.Exception.Backtrace
 
 -- Take advantage of the new backtrace support in ghc 9.10 and up.
 
-newtype Stack = WrapStack {
+newtype Backtrace = WrapStack {
       unwrapStack :: Backtraces
     }
 
-instance Show Stack where
-  show = prettyStack
+instance Show Backtrace where
+  show = prettyBacktrace
 
-prettyStack :: Stack -> String
-prettyStack = displayBacktraces . unwrapStack
+prettyBacktrace :: Backtrace -> String
+prettyBacktrace = displayBacktraces . unwrapStack
 
-getStack :: HasCallStack => IO Stack
-getStack = WrapStack <$> collectBacktraces
+collectBacktrace :: HasCallStack => IO Backtrace
+collectBacktrace = WrapStack <$> collectBacktraces
 
 #else
 
 -- For older ghc (< 9.10), we just use the 'CallStack'.
 
-newtype Stack = WrapStack {
+newtype Backtrace = WrapStack {
       unwrapStack :: CallStack
     }
 
-instance Show Stack where
-  show = prettyStack
+instance Show Backtrace where
+  show = prettyBacktrace
 
-prettyStack :: Stack -> String
-prettyStack = prettyCallStack . unwrapStack
+prettyBacktrace :: Backtrace -> String
+prettyBacktrace = prettyCallStack . unwrapStack
 
-getStack :: HasCallStack => IO Stack
-getStack = return $ WrapStack callStack
+collectBacktrace :: HasCallStack => IO Backtrace
+collectBacktrace = return $ WrapStack callStack
 
 #endif
 
@@ -64,15 +64,16 @@ getStack = return $ WrapStack callStack
 --
 -- In ghc 9.10 and higher, 'throwIO' will include a backtrace immediately, but
 -- this is not true for older versions. It is therefore useful to include an
--- explicit stack in exceptions, but if we do, we should then /also/ have
--- @ghc@'s stack annotation. Example usage:
+-- explicit backtrace in exceptions, but if we do, we should then not /also/
+-- have @ghc@'s automatic backtrace annotation. Example usage:
 --
--- > data CallFailed = CallFailed Stack
+-- > data CallFailed = CallFailed Backtrace
 -- >   deriving stock (Show)
-newtype ContainsStack a = ContainsStack a
+-- >   deriving Exception via CollectedBacktrac CallFailed
+newtype CollectedBacktrace a = CollectedBacktrace a
   deriving newtype Show
 
-instance (Show a, Typeable a) => Exception (ContainsStack a) where
+instance (Show a, Typeable a) => Exception (CollectedBacktrace a) where
 #if MIN_VERSION_base(4,20,0)
     backtraceDesired _ = False
 #endif

hs-bindgen/cbits/clang_wrappers.c

@@ -15,16 +15,24 @@ CXCursor* wrap_malloc_getTranslationUnitCursor (CXTranslationUnit unit) {
     return result;
 }
 
+unsigned wrap_equalCursors(CXCursor* a, CXCursor* b) {
+    return clang_equalCursors(*a, *b);
+}
+
 /**
  * Traversing the AST with cursors
  */
 
 enum CXChildVisitResult wrap_HsCXCursorVisitor(CXCursor cursor, CXCursor parent, CXClientData client_data) {
     HsCXCursorVisitor visitor = client_data;
-    return visitor(&cursor, &parent);
+    CXCursor* cursor_ = malloc(sizeof(CXCursor));
+    CXCursor* parent_ = malloc(sizeof(CXCursor));
+    *cursor_ = cursor;
+    *parent_ = parent;
+    return visitor(cursor_, parent_);
 }
 
-unsigned wrap_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor) {
+unsigned wrap_malloc_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor) {
     return clang_visitChildren(*parent, &wrap_HsCXCursorVisitor, visitor);
 }
 

hs-bindgen/cbits/clang_wrappers.h

@@ -14,15 +14,16 @@
  * Cursor manipulations
  */
 
-CXCursor* wrap_malloc_getTranslationUnitCursor (CXTranslationUnit unit);
+CXCursor* wrap_malloc_getTranslationUnitCursor(CXTranslationUnit unit);
+unsigned wrap_equalCursors(CXCursor* a, CXCursor* b);
 
 /**
  * Traversing the AST with cursors
  */
 
 typedef enum CXChildVisitResult(* HsCXCursorVisitor) (CXCursor* cursor, CXCursor* parent);
 
-unsigned wrap_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor);
+unsigned wrap_malloc_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor);
 
 /**
  * Cross-referencing in the AST

hs-bindgen/hs-bindgen.cabal

@@ -63,6 +63,7 @@ library
       HsBindgen.C.AST
       HsBindgen.C.Clang
       HsBindgen.C.Clang.Enums
+      HsBindgen.C.Clang.Fold
       HsBindgen.C.Clang.Instances
       HsBindgen.C.Clang.Util
       HsBindgen.C.Parser

hs-bindgen/src/HsBindgen/C/AST.hs

@@ -10,6 +10,8 @@ module HsBindgen.C.AST (
     Header(..)
   , Decl(..)
   , Struct(..)
+  , StructField(..)
+  , PrimType(..)
   ) where
 
 import GHC.Generics (Generic)
@@ -36,7 +38,21 @@ data Decl =
 data Struct = Struct {
       sizeof    :: Int
     , alignment :: Int
+    , fields    :: [StructField]
     }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (PrettyVal)
 
+data StructField = StructField {
+      fieldName :: String
+    , fieldType :: PrimType
+    }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (PrettyVal)
+
+data PrimType =
+    PrimInt   -- @int@
+  | PrimChar  -- @char@
+  | PrimFloat -- @float@
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (PrettyVal)