diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -15,6 +15,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where @@ -25,13 +26,14 @@ import Distribution.Simple import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup +import Distribution.Simple.Configure +import Distribution.Simple.Utils +import Distribution.Verbosity import System.Environment import System.IO.Error import System.Process - -data SetupException = SetupException String deriving Show - -instance Exception SetupException +import qualified Data.Version as Version +import Text.ParserCombinators.ReadP data LLVMPathInfo = LLVMPathInfo { llvmLibraryDir :: FilePath @@ -44,57 +46,94 @@ llvmIncludeDirEnvVarName :: String llvmIncludeDirEnvVarName = "CLANG_PURE_LLVM_INCLUDE_DIR" -findLLVMConfigPaths :: IO LLVMPathInfo -findLLVMConfigPaths = do +minVersion :: Version.Version +minVersion = Version.makeVersion [ 3, 8, 0 ] + +#if !(MIN_VERSION_Cabal(2, 0, 0)) +die' :: Verbosity -> String -> IO a +die' _ = die +#endif + +findLLVMConfigPaths :: Verbosity -> IO LLVMPathInfo +findLLVMConfigPaths verbosity = do let llvmConfigCandidates = "llvm-config" : [ "llvm-config-" ++ show major ++ "." ++ show minor | major <- [9,8..3 :: Int] , minor <- [9,8..0 :: Int] ] - let tryCandidates [] = throwIO $ SetupException "Could not find llvm-config." + let tryCandidates [] = die' verbosity $ "Could not find llvm-config with minimum version " ++ Version.showVersion minVersion ++ "." tryCandidates (llvmConfig : candidates) = do - llvmConfigResult <- tryJust (guard . isDoesNotExistError) (readProcess llvmConfig ["--libdir", "--includedir"] "") + llvmConfigResult <- tryJust + (guard . isDoesNotExistError) + (readProcess llvmConfig ["--version", "--libdir", "--includedir"] "") case llvmConfigResult of - Left _ -> tryCandidates candidates - Right llvmConfigOutput -> case lines llvmConfigOutput of - [ libraryDir, includeDir ] -> return $ LLVMPathInfo libraryDir includeDir - _ -> throwIO $ SetupException "Unexpected llvm-config output." + Left _ -> do + putStrLn ("Could not execute " ++ llvmConfig) + tryCandidates candidates + Right llvmConfigOutput -> do + putStrLn ("Found " ++ llvmConfig) + case lines llvmConfigOutput of + [ versionString, libraryDir, includeDir ] -> + case readP_to_S (Version.parseVersion <* eof) versionString of + [ ( version, _ ) ] + | version >= minVersion -> return $ LLVMPathInfo libraryDir includeDir + | otherwise -> do + putStrLn ("Version too low: " ++ show version) + tryCandidates candidates + _ -> die' verbosity "Couldn't parse llvm-config version string." + _ -> die' verbosity "Unexpected llvm-config output." tryCandidates llvmConfigCandidates -getLLVMPathInfo :: IO LLVMPathInfo -getLLVMPathInfo = do +getLLVMPathInfo :: Verbosity -> IO LLVMPathInfo +getLLVMPathInfo verbosity = do m'llvmLibDirEnvVar <- lookupEnv llvmLibDirEnvVarName m'llvmIncludeDirEnvVar <- lookupEnv llvmIncludeDirEnvVarName case (m'llvmLibDirEnvVar, m'llvmIncludeDirEnvVar) of ( Just libraryDir, Just includeDir ) -> return $ LLVMPathInfo libraryDir includeDir - _ -> findLLVMConfigPaths + _ -> findLLVMConfigPaths verbosity clangPureConfHook :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo clangPureConfHook (d, bi) flags = do localBuildInfo <- confHook simpleUserHooks (d, bi) flags let pd = localPkgDescr localBuildInfo - let Just lib = library pd - let lbi = libBuildInfo lib - LLVMPathInfo{..} <- getLLVMPathInfo + -- see if it just works (eg on Nix) + mbError <- try $ checkForeignDeps pd localBuildInfo normal - return localBuildInfo { - localPkgDescr = pd { - library = Just $ lib { - libBuildInfo = lbi - { includeDirs = llvmIncludeDir : includeDirs lbi - , extraLibDirs = llvmLibraryDir : extraLibDirs lbi - , cSources = -- define the generated c-sources here so that they don't get picked up by sdist -#ifdef mingw32_HOST_OS - ["srcLanguageCClangInternalFFI.c"] -- work around a bug in inline-c (?) + let verbosity = fromFlagOrDefault normal (configVerbosity flags) + + let addCSources libBuildInfo = + libBuildInfo +#if !(MIN_VERSION_GLASGOW_HASKELL(8, 2, 1, 0) && MIN_VERSION_inline_c(0, 6, 0)) + { cSources = -- define the generated c-sources here so that they don't get picked up by sdist +#if defined(mingw32_HOST_OS) && !(MIN_VERSION_GLASGOW_HASKELL(8, 0, 2, 0)) + ["srcLanguageCClangInternalFFI.c"] -- work around a bug in hsc2hs #else - ["src/Language/C/Clang/Internal/FFI.c"] + ["src/Language/C/Clang/Internal/FFI.c"] #endif + } +#endif + + addDirs <- case mbError of + Right () -> return id + Left (_ :: SomeException) -> do + warn verbosity "Couldn't find libclang, attempting to find it with llvm-config or environment variables..." + + LLVMPathInfo{..} <- getLLVMPathInfo verbosity + + return $ \libBuildInfo -> libBuildInfo + { includeDirs = llvmIncludeDir : includeDirs libBuildInfo + , extraLibDirs = llvmLibraryDir : extraLibDirs libBuildInfo } + + let Just lib = library pd + let lbi = libBuildInfo lib + return localBuildInfo + { localPkgDescr = pd + { library = Just lib { libBuildInfo = addDirs $ addCSources lbi } } } - } main :: IO () main = defaultMainWithHooks simpleUserHooks { confHook = clangPureConfHook } diff --git a/cbits/clang-pure-utils.h b/cbits/clang-pure-utils.h new file mode 100644 --- /dev/null +++ b/cbits/clang-pure-utils.h @@ -0,0 +1,35 @@ +/* +Copyright 2014 Google Inc. All Rights Reserved. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +*/ + +typedef void (*haskell_visitor)(CXCursor*); + +// Macro that evaluates to a copy on the heap of the result of a given expression. +#define ALLOC(__ALLOC_EXPR__) ({\ + typeof (__ALLOC_EXPR__) __alloc_res__ = (__ALLOC_EXPR__);\ + typeof (__ALLOC_EXPR__) *__alloc_ptr__ = malloc(sizeof(__alloc_res__));\ + *__alloc_ptr__ = __alloc_res__;\ + __alloc_ptr__;\ + }) + +// Traverse children using a haskell_visitor passed in as client_data. +// The visitor gets a copy of the cursor on the heap and is responsible +// for freeing it. +static enum CXChildVisitResult visit_haskell(CXCursor cursor, + CXCursor parent, + CXClientData client_data) { + ((haskell_visitor) client_data)(ALLOC(cursor)); + return CXChildVisit_Continue; +}; diff --git a/cbits/utils.h b/cbits/utils.h deleted file mode 100644 --- a/cbits/utils.h +++ /dev/null @@ -1,35 +0,0 @@ -/* -Copyright 2014 Google Inc. All Rights Reserved. - -Licensed under the Apache License, Version 2.0 (the "License"); -you may not use this file except in compliance with the License. -You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, software -distributed under the License is distributed on an "AS IS" BASIS, -WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and -limitations under the License. -*/ - -typedef void (*haskell_visitor)(CXCursor*); - -// Macro that evaluates to a copy on the heap of the result of a given expression. -#define ALLOC(__ALLOC_EXPR__) ({\ - typeof (__ALLOC_EXPR__) __alloc_res__ = (__ALLOC_EXPR__);\ - typeof (__ALLOC_EXPR__) *__alloc_ptr__ = malloc(sizeof(__alloc_res__));\ - *__alloc_ptr__ = __alloc_res__;\ - __alloc_ptr__;\ - }) - -// Traverse children using a haskell_visitor passed in as client_data. -// The visitor gets a copy of the cursor on the heap and is responsible -// for freeing it. -static enum CXChildVisitResult visit_haskell(CXCursor cursor, - CXCursor parent, - CXClientData client_data) { - ((haskell_visitor) client_data)(ALLOC(cursor)); - return CXChildVisit_Continue; -}; diff --git a/clang-pure.cabal b/clang-pure.cabal --- a/clang-pure.cabal +++ b/clang-pure.cabal @@ -1,5 +1,5 @@ name: clang-pure -version: 0.2.0.2 +version: 0.2.0.3 synopsis: Pure C++ code analysis with libclang description: Pure C++ code analysis with libclang. @@ -13,9 +13,16 @@ copyright: Copyright 2014 Google Inc. All Rights Reserved. category: Language build-type: Custom -cabal-version: >=1.10 -extra-source-files: cbits/utils.h +cabal-version: >=1.24 +extra-source-files: cbits/clang-pure-utils.h +custom-setup + setup-depends: + base >= 4.5 && < 5, + Cabal >= 1.24, + process >= 1.3.0.0, + inline-c + source-repository head type: git location: https://github.com/chpatrick/clang-pure.git @@ -57,35 +64,39 @@ build-tools: hsc2hs default-language: Haskell2010 include-dirs: cbits/ - cc-options: -Wall + includes: clang-c/Index.h + cc-options: -Wall -Werror extra-libraries: clang - ghc-options: -Wall -O2 + ghc-options: -Wall if impl(ghc >= 8.0.0) ghc-options: -fno-warn-redundant-constraints executable find-classes main-is: FindClasses.hs + default-language: Haskell2010 build-depends: base, clang-pure, lens, unordered-containers, hashable, bytestring hs-source-dirs: app buildable: False - ghc-options: -Wall -O2 -fno-warn-orphans + ghc-options: -Wall -fno-warn-orphans if impl(ghc >= 8.0.0) ghc-options: -fno-warn-redundant-constraints -executable list-fun-types +test-suite list-fun-types + type: exitcode-stdio-1.0 main-is: ListTypes.hs + default-language: Haskell2010 build-depends: base, clang-pure, lens, bytestring hs-source-dirs: examples - buildable: False - ghc-options: -Wall -O2 + ghc-options: -Wall if impl(ghc >= 8.0.0) ghc-options: -fno-warn-redundant-constraints -executable list-structs +test-suite list-structs + type: exitcode-stdio-1.0 + default-language: Haskell2010 main-is: ListStructs.hs build-depends: base, clang-pure, lens, bytestring hs-source-dirs: examples - buildable: False - ghc-options: -Wall -O2 + ghc-options: -Wall if impl(ghc >= 8.0.0) ghc-options: -fno-warn-redundant-constraints diff --git a/examples/ListStructs.hs b/examples/ListStructs.hs --- a/examples/ListStructs.hs +++ b/examples/ListStructs.hs @@ -6,14 +6,24 @@ import Language.C.Clang.Cursor.Typed import Control.Lens import qualified Data.ByteString.Char8 as BS -import Data.Monoid +import Data.Maybe import Data.Word import System.Environment +data CType = + CArrayType { cType :: Type + , cCanonicalType :: Type + , cElementType :: CType + , cArraySize :: Word64, cSize :: Word64} | + CScalarType { cType :: Type + , cCanonicalType :: Type + , cSize :: Word64 + } deriving (Show) + data CField = CField { cFieldName :: BS.ByteString , cFieldOffset :: Word64 - , cFieldType :: Type + , cFieldType :: CType } deriving (Show) data CStruct = CStruct @@ -29,12 +39,33 @@ idx <- createIndex tu <- parseTranslationUnit idx path clangArgs + let toCType tp = let canonicalType = typeCanonicalType tp + in case typeKind canonicalType of + ConstantArray -> do + elementType <- toCType . fromJust . typeElementType $ canonicalType + size <- typeSizeOf tp + pure $ CArrayType + { cType = tp + , cCanonicalType = canonicalType + , cElementType = elementType + , cArraySize = fromJust (typeArraySize canonicalType) + , cSize = size + } + _ -> do + size <- typeSizeOf tp + pure $ CScalarType + { cType = tp + , cCanonicalType = canonicalType + , cSize = size + } + let toCField fieldDecC = do - offset <- offsetOfField fieldDecC + fieldOffset <- offsetOfField fieldDecC + fieldType <- toCType (cursorType fieldDecC) return $ CField { cFieldName = cursorSpelling fieldDecC - , cFieldOffset = offset - , cFieldType = cursorType fieldDecC + , cFieldOffset = fieldOffset + , cFieldType = fieldType } let toCStruct structDecC = do @@ -43,7 +74,10 @@ ^.. cursorDescendantsF . folding (matchKind @'FieldDecl) cFields <- traverse toCField fieldDecs - return $ CStruct (cursorSpelling structDecC) cFields + return CStruct + { cStructName = cursorSpelling structDecC + , cStructFields = cFields + } let cStructs = translationUnitCursor tu diff --git a/examples/ListTypes.hs b/examples/ListTypes.hs --- a/examples/ListTypes.hs +++ b/examples/ListTypes.hs @@ -6,8 +6,8 @@ import Language.C.Clang.Cursor.Typed import Control.Lens import qualified Data.ByteString.Char8 as BS -import Data.Monoid import System.Environment +import Data.Monoid ((<>)) main :: IO () main = do diff --git a/src/Language/C/Clang/Cursor/Typed.hs b/src/Language/C/Clang/Cursor/Typed.hs --- a/src/Language/C/Clang/Cursor/Typed.hs +++ b/src/Language/C/Clang/Cursor/Typed.hs @@ -83,11 +83,11 @@ cursorChildren = UT.cursorChildren . withoutKind -- | `Fold` over a `CursorK` and all of its descendants recursively. -cursorDescendantsF :: Fold (CursorK kind) Cursor +cursorDescendantsF :: HasChildren kind => Fold (CursorK kind) Cursor cursorDescendantsF = to withoutKind . UT.cursorDescendantsF -- | List a `CursorK` and all of its descendants recursively. -cursorDescendants :: CursorK kind -> [ Cursor ] +cursorDescendants :: HasChildren kind => CursorK kind -> [ Cursor ] cursorDescendants = UT.cursorDescendants . withoutKind class HasExtent (kind :: CursorKind) diff --git a/src/Language/C/Clang/Internal/Context.hs b/src/Language/C/Clang/Internal/Context.hs --- a/src/Language/C/Clang/Internal/Context.hs +++ b/src/Language/C/Clang/Internal/Context.hs @@ -17,7 +17,7 @@ module Language.C.Clang.Internal.Context where import qualified Data.Map as M -import Data.Monoid +import Data.Monoid ((<>)) import qualified Language.C.Inline as C import qualified Language.C.Inline.Context as C import qualified Language.C.Types as C diff --git a/src/Language/C/Clang/Internal/FFI.hsc b/src/Language/C/Clang/Internal/FFI.hsc --- a/src/Language/C/Clang/Internal/FFI.hsc +++ b/src/Language/C/Clang/Internal/FFI.hsc @@ -42,7 +42,7 @@ C.include "stdlib.h" #include "clang-c/Index.h" C.include "clang-c/Index.h" -C.include "utils.h" +C.include "clang-pure-utils.h" foreign import ccall "clang_disposeIndex" clang_disposeIndex :: Ptr CXIndexImpl -> Finalizer @@ -117,7 +117,7 @@ cursorChildrenF f c = uderef c $ \cp -> do -- initialize the "Fold state" with no effect fRef <- newIORef $ phantom $ pure () - let + let visitChild chp = do ch <- newLeaf (cursorTranslationUnit c) $ \_ -> return ( chp, free chp ) @@ -468,6 +468,31 @@ then return Nothing else (Just . Type) <$> newLeaf (parent c) (\_ -> return ( tp, free tp )) +typeArraySize :: Type -> Maybe Word64 +typeArraySize t = uderef t $ \tp -> do + as <- [C.exp| long long { clang_getArraySize(*$(CXType *tp)) } |] + return $ if as == -1 then Nothing else Just (fromIntegral as) + +typeCanonicalType :: Type -> Type +typeCanonicalType t = uderef t $ \tp -> do + ctp <- [C.exp| CXType* { ALLOC(clang_getCanonicalType(*$(CXType *tp))) } |] + Type <$> newLeaf (parent t) (\_ -> pure (ctp, free ctp)) + +typeElementType :: Type -> Maybe Type +typeElementType t = uderef t $ \tp -> do + etp <- [C.block| CXType* { + CXType type = clang_getElementType(*$(CXType *tp)); + + if (type.kind == CXType_Invalid) { + return NULL; + } + + return ALLOC(type); + } |] + if etp == nullPtr + then return Nothing + else (Just . Type) <$> newLeaf (parent t) (\_ -> return ( etp, free etp )) + typeKind :: Type -> TypeKind typeKind t = uderef t $ fmap parseTypeKind . #peek CXType, kind @@ -525,6 +550,23 @@ #{const CXType_MemberPointer} -> MemberPointer _ -> Unexposed +eitherTypeLayoutErrorOrWord64 :: CLLong -> Either TypeLayoutError Word64 +eitherTypeLayoutErrorOrWord64 n = case n of + #{const CXTypeLayoutError_Invalid} -> Left TypeLayoutErrorInvalid + #{const CXTypeLayoutError_Incomplete} -> Left TypeLayoutErrorIncomplete + #{const CXTypeLayoutError_Dependent} -> Left TypeLayoutErrorDependent + _ -> Right $ fromIntegral n + +typeSizeOf :: Type -> Either TypeLayoutError Word64 +typeSizeOf t = uderef t $ \tp -> + eitherTypeLayoutErrorOrWord64 <$> + [C.exp| long long { clang_Type_getSizeOf(*$(CXType *tp)) } |] + +offsetOfField :: Cursor -> Either TypeLayoutError Word64 +offsetOfField c = uderef c $ \cp -> + eitherTypeLayoutErrorOrWord64 <$> + [C.exp| long long { clang_Cursor_getOffsetOfField(*$(CXCursor* cp)) } |] + typeSpelling :: Type -> ByteString typeSpelling t = uderef t $ \tp -> withCXString $ \cxsp -> @@ -548,7 +590,7 @@ ( tsp, tn ) <- C.withPtrs_ $ \( tspp, tnp ) -> [C.exp| void { clang_tokenize( - $(CXTranslationUnit tup), + $(CXTranslationUnit tup), *$(CXSourceRange *srp), $(CXToken **tspp), $(unsigned int *tnp)); @@ -610,12 +652,3 @@ "File { fileName = " ++ show (fileName f) ++ "}" - -offsetOfField :: Cursor -> Either TypeLayoutError Word64 -offsetOfField c = uderef c $ \cp -> do - res <- [C.exp| long long { clang_Cursor_getOffsetOfField(*$(CXCursor* cp)) } |] - return $ case res of - #{const CXTypeLayoutError_Invalid} -> Left TypeLayoutErrorInvalid - #{const CXTypeLayoutError_Incomplete} -> Left TypeLayoutErrorIncomplete - #{const CXTypeLayoutError_Dependent} -> Left TypeLayoutErrorDependent - n -> Right (fromIntegral n) diff --git a/src/Language/C/Clang/Internal/Types.hs b/src/Language/C/Clang/Internal/Types.hs --- a/src/Language/C/Clang/Internal/Types.hs +++ b/src/Language/C/Clang/Internal/Types.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} module Language.C.Clang.Internal.Types where diff --git a/src/Language/C/Clang/Type.hs b/src/Language/C/Clang/Type.hs --- a/src/Language/C/Clang/Type.hs +++ b/src/Language/C/Clang/Type.hs @@ -16,6 +16,10 @@ module Language.C.Clang.Type ( Type() + , typeArraySize + , typeCanonicalType + , typeElementType + , typeSizeOf , typeSpelling , typeKind , TypeKind(..)