clang-pure 0.2.0.2 → 0.2.0.3

raw patch · 11 files changed

+220/−98 lines, 11 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Setup.hs +68/−29
• cbits/clang-pure-utils.h +35/−0
• cbits/utils.h +0/−35
• clang-pure.cabal +23/−12
• examples/ListStructs.hs +40/−6
• examples/ListTypes.hs +1/−1
• src/Language/C/Clang/Cursor/Typed.hs +2/−2
• src/Language/C/Clang/Internal/Context.hs +1/−1
• src/Language/C/Clang/Internal/FFI.hsc +45/−12
• src/Language/C/Clang/Internal/Types.hs +1/−0
• src/Language/C/Clang/Type.hs +4/−0

@@ -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 }

@@ -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;+};

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

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

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

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

@@ -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)

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

@@ -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)

@@ -17,6 +17,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}  module Language.C.Clang.Internal.Types where 

@@ -16,6 +16,10 @@  module Language.C.Clang.Type   ( Type()+  , typeArraySize+  , typeCanonicalType+  , typeElementType+  , typeSizeOf   , typeSpelling   , typeKind   , TypeKind(..)