Merge pull request #137 from well-typed/target-info

Add target info bindings

hs-bindgen-libclang/cbits/clang_wrappers.c

@@ -223,3 +223,12 @@ const char * wrap_getCString (CXString* string) {
 void wrap_disposeString(CXString* string) {
     clang_disposeString(*string);
 }
+
+/**
+ * Target info
+ */
+CXString *wrap_malloc_TargetInfo_getTriple(CXTargetInfo Info) {
+    CXString* result = malloc(sizeof(CXString));
+    *result = clang_TargetInfo_getTriple(Info);
+    return result;
+}

hs-bindgen-libclang/cbits/clang_wrappers.h

@@ -94,4 +94,10 @@ CXString* wrap_malloc_getFileName(CXFile SFile);
 const char * wrap_getCString(CXString* string);
 void wrap_disposeString(CXString* string);
 
-#endif
+/**
+ * Target info
+ */
+
+CXString* wrap_malloc_TargetInfo_getTriple(CXTargetInfo Info);
+
+#endif

hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs

@@ -124,6 +124,11 @@ module HsBindgen.Clang.Core (
   , CXTypeLayoutException(..)
     -- * Exported for the benefit of other bindings
   , CXCursor_(..)
+    -- * Target info
+  , CXTargetInfo(..)
+  , clang_getTranslationUnitTargetInfo
+  , clang_TargetInfo_dispose
+  , clang_TargetInfo_getTriple
   ) where
 
 import Control.Exception
@@ -857,3 +862,25 @@ data CXTypeLayoutException =
     CXTypeLayoutException Backtrace CInt (Maybe CXTypeLayoutError)
   deriving stock (Show)
   deriving Exception via CollectedBacktrace CXTypeLayoutException
+
+{-------------------------------------------------------------------------------
+  Exceptions
+-------------------------------------------------------------------------------}
+
+-- | An opaque type representing target information for a given translation
+newtype {-# CType "CXTargetInfo" #-} CXTargetInfo = CXTargetInfo (Ptr ())
+  deriving newtype (IsPointer)
+
+foreign import capi "clang_wrappers.h clang_getTranslationUnitTargetInfo"
+  clang_getTranslationUnitTargetInfo :: CXTranslationUnit -> IO CXTargetInfo
+
+foreign import capi "clang_wrappers.h clang_TargetInfo_dispose"
+  clang_TargetInfo_dispose :: CXTargetInfo -> IO ()
+
+-- | Get the normalized target triple as a string.
+foreign import capi "clang_wrappers.h wrap_malloc_TargetInfo_getTriple"
+  wrap_malloc_TargetInfo_getTriple :: CXTargetInfo -> IO CXString
+
+clang_TargetInfo_getTriple :: CXTargetInfo -> IO ByteString
+clang_TargetInfo_getTriple info =
+    packCXString =<< wrap_malloc_TargetInfo_getTriple info

hs-bindgen/hs-bindgen.cabal

@@ -105,4 +105,5 @@ test-suite golden
     , filepath     ^>=1.4.2.2 || ^>=1.5.2.0
     , tasty        ^>=1.5
     , tasty-golden ^>=2.3.5
+    , tasty-hunit  ^>=0.10.2
     , tree-diff    ^>=0.3.1

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

@@ -5,14 +5,17 @@
 -- > import Hsbindgen.C.Parser qualified as C
 module HsBindgen.C.Parser (
     parseHeaderWith
+  , withTranslationUnit
   , foldDecls
     -- * Debugging
   , Element(..)
   , foldClangAST
+  , getTranslationUnitTargetTriple
     -- * Logging
   , ParseMsg(..)
   ) where
 
+import Control.Exception (bracket)
 import Data.ByteString qualified as Strict (ByteString)
 import Data.ByteString.Char8 qualified as BS.Strict.Char8
 import Data.Tree
@@ -27,26 +30,44 @@ import HsBindgen.Patterns
 import HsBindgen.Util.Tracer
 
 {-------------------------------------------------------------------------------
-  Parsing
+  General setup
 -------------------------------------------------------------------------------}
 
-parseHeaderWith ::
+withTranslationUnit ::
      ClangArgs
   -> FilePath
-  -> (CXTranslationUnit -> Fold a)
-  -> IO [a]
-parseHeaderWith args fp fold = do
+  -> (CXTranslationUnit -> IO r)
+  -> IO r
+withTranslationUnit args fp kont = do
     index  <- clang_createIndex DontDisplayDiagnostics
     unit   <- clang_parseTranslationUnit index fp args flags
-    cursor <- clang_getTranslationUnitCursor unit
-
-    clang_fold cursor $ fold unit
+    kont unit
   where
     flags :: CXTranslationUnit_Flags
     flags = bitfieldEnum [
           CXTranslationUnit_SkipFunctionBodies
         ]
 
+getTranslationUnitTargetTriple :: CXTranslationUnit -> IO Strict.ByteString
+getTranslationUnitTargetTriple unit =
+    bracket
+        (clang_getTranslationUnitTargetInfo unit)
+        clang_TargetInfo_dispose
+        clang_TargetInfo_getTriple
+
+{-------------------------------------------------------------------------------
+  Parsing
+-------------------------------------------------------------------------------}
+
+parseHeaderWith ::
+     ClangArgs
+  -> FilePath
+  -> (CXTranslationUnit -> Fold a)
+  -> IO [a]
+parseHeaderWith args fp fold = withTranslationUnit args fp $ \unit -> do
+    cursor <- clang_getTranslationUnitCursor unit
+    clang_fold cursor $ fold unit
+
 {-------------------------------------------------------------------------------
   Top-level
 -------------------------------------------------------------------------------}

hs-bindgen/src/HsBindgen/Lib.hs

@@ -36,6 +36,7 @@ module HsBindgen.Lib (
     -- * Debugging
   , Element(..)
   , getClangAST
+  , getTargetTriple
 
     -- * Logging
   , Tracer
@@ -46,6 +47,7 @@ module HsBindgen.Lib (
   ) where
 
 import Data.Tree (Forest)
+import Data.ByteString qualified as Strict (ByteString)
 import GHC.Generics (Generic)
 import Language.Haskell.Exts qualified as Hs
 import Language.Haskell.Meta qualified as Meta
@@ -147,3 +149,7 @@ preprocess tracer clangArgs inp modOpts renderOpts out = do
 -- This is primarily for debugging.
 getClangAST :: ClangArgs -> FilePath -> IO (Forest Element)
 getClangAST args fp = C.parseHeaderWith args fp C.foldClangAST
+
+-- | Return the target triple for translation unit
+getTargetTriple :: ClangArgs -> FilePath -> IO Strict.ByteString
+getTargetTriple args fp = C.withTranslationUnit args fp C.getTranslationUnitTargetTriple

hs-bindgen/tests/golden.hs

@@ -1,10 +1,12 @@
 module Main (main) where
 
+import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Tree (Tree (..))
 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)
@@ -19,7 +21,16 @@ main :: IO ()
 main = do
     findPackageDirectory "hs-bindgen"
     defaultMain $ testGroup "golden"
-        [ golden "simple_structs"
+        [ testCase "target-triple" $ do
+            let fp = "examples/simple_structs.h"
+                args = ["-target", "x86_64-pc-linux-gnu"]
+            triple <- getTargetTriple args fp
+
+            -- macos-latest (macos-14) returns "arm64-apple-macosx14.0.0"
+            -- windows-latest (???) returns "x86_64-pc-windows-msvc19.41.34120"
+            triple @?= BS8.pack "x86_64-pc-linux-gnu"
+
+        , golden "simple_structs"
         , golden "nested_types"
         , golden "enums"
         , golden "primitive_types"