From 3290665792b2ad686a5d9c8167b48b0ed7eb276a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 1 Sep 2024 17:28:38 +0300 Subject: [PATCH 1/2] Add target info bindings --- hs-bindgen-libclang/cbits/clang_wrappers.c | 9 +++++ hs-bindgen-libclang/cbits/clang_wrappers.h | 8 +++- .../src/HsBindgen/Clang/Core.hs | 27 ++++++++++++++ hs-bindgen/hs-bindgen.cabal | 1 + hs-bindgen/src/HsBindgen/C/Parser.hs | 37 +++++++++++++++---- hs-bindgen/src/HsBindgen/Lib.hs | 6 +++ hs-bindgen/tests/golden.hs | 11 +++++- 7 files changed, 89 insertions(+), 10 deletions(-) diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.c b/hs-bindgen-libclang/cbits/clang_wrappers.c index 4e23110d..a7139d72 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.c +++ b/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; +} diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.h b/hs-bindgen-libclang/cbits/clang_wrappers.h index 93b94ebe..c1e2ae3c 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.h +++ b/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 \ No newline at end of file +/** + * Target info + */ + +CXString* wrap_malloc_TargetInfo_getTriple(CXTargetInfo Info); + +#endif diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs index 68f3f67d..daab9c67 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs +++ b/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 diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 2d4ce34d..c84fee4a 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/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 diff --git a/hs-bindgen/src/HsBindgen/C/Parser.hs b/hs-bindgen/src/HsBindgen/C/Parser.hs index 1ffe3784..b21eea68 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser.hs +++ b/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 -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src/HsBindgen/Lib.hs b/hs-bindgen/src/HsBindgen/Lib.hs index 00d4a29c..d1706d60 100644 --- a/hs-bindgen/src/HsBindgen/Lib.hs +++ b/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 diff --git a/hs-bindgen/tests/golden.hs b/hs-bindgen/tests/golden.hs index 8517da6c..05e8e006 100644 --- a/hs-bindgen/tests/golden.hs +++ b/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,14 @@ main :: IO () main = do findPackageDirectory "hs-bindgen" defaultMain $ testGroup "golden" - [ golden "simple_structs" + [ testCase "target-triple" $ do + let fp = "examples/simple_structs.h" + args = [] + triple <- getTargetTriple args fp + + triple @?= BS8.pack "x86_64-pc-linux-gnu" + + , golden "simple_structs" , golden "nested_types" , golden "enums" , golden "primitive_types" From 9e7f198dbdd59b70fde5f9f171753cc1d479f9b6 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 1 Sep 2024 17:34:05 +0300 Subject: [PATCH 2/2] Hardcode target in tests --- hs-bindgen/tests/golden.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hs-bindgen/tests/golden.hs b/hs-bindgen/tests/golden.hs index 05e8e006..2f8c4cf4 100644 --- a/hs-bindgen/tests/golden.hs +++ b/hs-bindgen/tests/golden.hs @@ -23,9 +23,11 @@ main = do defaultMain $ testGroup "golden" [ testCase "target-triple" $ do let fp = "examples/simple_structs.h" - args = [] + 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"