clang-pure 0.2.0.1 → 0.2.0.2

raw patch · 8 files changed

+143/−45 lines, 8 filesdep ~basedep ~bytestringnew-component:exe:list-structsPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• app/FindClasses.hs +1/−1
• clang-pure.cabal +10/−1
• examples/ListStructs.hs +57/−0
• examples/ListTypes.hs +1/−23
• src/Language/C/Clang/Cursor.hs +20/−2
• src/Language/C/Clang/Cursor/Typed.hs +21/−3
• src/Language/C/Clang/Internal/FFI.hsc +27/−15
• src/Language/C/Clang/Internal/Types.hs +6/−0

@@ -64,4 +64,4 @@ findClass :: HasClass -> Cursor -> HMS.HashMap CursorKind Bool findClass HasClass {..} root = HMS.fromListWith combineResults kindResults   where-    kindResults = root ^.. cosmosOf cursorChildrenF . to (\c -> ( cursorKind c, predicate c ) )+    kindResults = root ^.. cursorDescendantsF . to (\c -> ( cursorKind c, predicate c ) )

@@ -1,5 +1,5 @@ name:                  clang-pure-version:               0.2.0.1+version:               0.2.0.2 synopsis:              Pure C++ code analysis with libclang description:   Pure C++ code analysis with libclang.@@ -74,6 +74,15 @@  executable list-fun-types   main-is:             ListTypes.hs+  build-depends:       base, clang-pure, lens, bytestring+  hs-source-dirs:      examples+  buildable:           False+  ghc-options:         -Wall -O2+  if impl(ghc >= 8.0.0)+    ghc-options: -fno-warn-redundant-constraints++executable list-structs+  main-is:             ListStructs.hs   build-depends:       base, clang-pure, lens, bytestring   hs-source-dirs:      examples   buildable:           False

@@ -0,0 +1,57 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++import           Language.C.Clang+import           Language.C.Clang.Cursor.Typed+import           Control.Lens+import qualified Data.ByteString.Char8 as BS+import           Data.Monoid+import           Data.Word+import           System.Environment++data CField = CField+  { cFieldName :: BS.ByteString+  , cFieldOffset :: Word64+  , cFieldType :: Type+  } deriving (Show)++data CStruct = CStruct+  { cStructName :: BS.ByteString+  , cStructFields :: [ CField ]+  } deriving (Show)++main :: IO ()+main = do+  args <- getArgs+  case args of+    path : clangArgs -> do+      idx <- createIndex+      tu <- parseTranslationUnit idx path clangArgs++      let toCField fieldDecC = do+            offset <- offsetOfField fieldDecC+            return $ CField+              { cFieldName = cursorSpelling fieldDecC+              , cFieldOffset = offset+              , cFieldType = cursorType fieldDecC+              }++      let toCStruct structDecC = do+            let fieldDecs =+                  structDecC+                    ^.. cursorDescendantsF+                      . folding (matchKind @'FieldDecl)+            cFields <- traverse toCField fieldDecs+            return $ CStruct (cursorSpelling structDecC) cFields++      let cStructs =+            translationUnitCursor tu+              ^.. cursorDescendantsF+                . folding (matchKind @'StructDecl)+                . to toCStruct+                . _Right++      print cStructs++    _ -> putStrLn "usage: list-structs path [clang opts]"

@@ -1,30 +1,8 @@-{--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.--}--{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}  import           Language.C.Clang-import qualified Language.C.Clang.Cursor as UT import           Language.C.Clang.Cursor.Typed import           Control.Lens import qualified Data.ByteString.Char8 as BS@@ -39,7 +17,7 @@       idx <- createIndex       tu <- parseTranslationUnit idx path clangArgs       let funDecs =-              cosmosOnOf cursorChildrenF UT.cursorChildrenF         -- fold over cursors recursively+              cursorDescendantsF                                    -- fold over cursors recursively             . folding (matchKind @'FunctionDecl)                    -- find only FunctionDecls...             . filtered (isFromMainFile . rangeStart . cursorExtent) -- ...that are actually in the given file             . to (\funDec -> cursorSpelling funDec <> " :: " <> typeSpelling (cursorType funDec))

@@ -27,20 +27,38 @@   , cursorTranslationUnit   , cursorChildrenF   , cursorChildren+  , cursorDescendantsF+  , cursorDescendants   , cursorSpelling   , cursorExtent   , cursorUSR   , cursorReferenced   , cursorType   , cursorKind++  , TypeLayoutError(..)+  , offsetOfField   , CursorKind(..)   ) where +import Data.Functor.Contravariant+import Lens.Micro+import Lens.Micro.Contra+ import Language.C.Clang.Internal.FFI import Language.C.Clang.Internal.Types -import Lens.Micro- cursorChildren :: Cursor -> [ Cursor ] cursorChildren = toListOf cursorChildrenF++cosmosOf :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a+cosmosOf d f s = f s *> d (cosmosOf d f) s++-- | `Fold` over a `Cursor` and all of its descendants recursively.+cursorDescendantsF :: Fold Cursor Cursor+cursorDescendantsF = cosmosOf cursorChildrenF++-- | List a `Cursor` and all of its descendants recursively.+cursorDescendants :: Cursor -> [ Cursor ]+cursorDescendants = toListOf cursorDescendantsF

@@ -23,11 +23,16 @@    , cursorChildrenF   , cursorChildren+  , cursorDescendantsF+  , cursorDescendants    , cursorExtent    , cursorSpelling +  , TypeLayoutError(..)+  , offsetOfField+   , HasType   , HasChildren   , HasExtent@@ -39,19 +44,19 @@ import           Data.Functor.Contravariant import           Data.Maybe import           Data.Singletons+import           Data.Word import           Lens.Micro.Contra  import qualified Language.C.Clang.Cursor as UT import           Language.C.Clang.Cursor ( cursorKind, Cursor, CursorKind(..) ) import           Language.C.Clang.Location-import           Language.C.Clang.Type-import           Language.C.Clang.TranslationUnit+import           Language.C.Clang.Internal.Types  import           Language.C.Clang.Internal.Refs (Clang)  -- | A `Cursor` with a statically known `CursorKind`. newtype CursorK (kind :: CursorKind) = CursorK { withoutKind :: Cursor }-  deriving (Eq, Clang)+  deriving (Eq, Clang, Show)  -- | Match a `Cursor` as a particular `CursorKind`. You can use the @TypeApplications@ extension to easily specify the `CursorKind` you want: @matchKind \@'StructDecl@. matchKind :: forall kind. SingI kind => Cursor -> Maybe (CursorK kind)@@ -77,6 +82,14 @@ cursorChildren :: HasChildren kind => CursorK kind -> [ Cursor ] cursorChildren = UT.cursorChildren . withoutKind +-- | `Fold` over a `CursorK` and all of its descendants recursively.+cursorDescendantsF :: Fold (CursorK kind) Cursor+cursorDescendantsF = to withoutKind . UT.cursorDescendantsF++-- | List a `CursorK` and all of its descendants recursively.+cursorDescendants :: CursorK kind -> [ Cursor ]+cursorDescendants = UT.cursorDescendants . withoutKind+ class HasExtent (kind :: CursorKind)  cursorExtent :: HasExtent kind => CursorK kind -> SourceRange@@ -87,6 +100,9 @@ cursorSpelling :: HasSpelling kind => CursorK kind -> BS.ByteString cursorSpelling = UT.cursorSpelling . withoutKind +offsetOfField :: CursorK 'FieldDecl -> Either TypeLayoutError Word64+offsetOfField = UT.offsetOfField . withoutKind+ -- instances derived experimentally with the find-classes executable instance HasChildren 'ArraySubscriptExpr instance HasChildren 'BinaryOperator@@ -274,6 +290,7 @@ instance HasSpelling 'ConversionFunction instance HasSpelling 'Destructor instance HasSpelling 'EnumConstantDecl+instance HasSpelling 'FieldDecl instance HasSpelling 'FunctionDecl instance HasSpelling 'FunctionTemplate instance HasSpelling 'MemberRef@@ -281,6 +298,7 @@ instance HasSpelling 'NamespaceRef instance HasSpelling 'OverloadedDeclRef instance HasSpelling 'StringLiteral+instance HasSpelling 'StructDecl instance HasSpelling 'TemplateRef instance HasSpelling 'TranslationUnit instance HasSpelling 'TypeRef

@@ -78,17 +78,20 @@ parseTranslationUnit idx path args = do   tun <- newNode idx $ \idxp ->     withCString path $ \cPath -> do-      cArgs <- VS.fromList <$> traverse newCString args-      ( tup, cres ) <- C.withPtr $ \tupp -> [C.exp| int {-        clang_parseTranslationUnit2(-          $(CXIndex idxp),-          $(char* cPath),-          $vec-ptr:(const char * const * cArgs), $vec-len:cArgs,-          NULL, 0,-          0,-          $(CXTranslationUnit *tupp))-        } |]-      traverse_ free $ VS.toList cArgs+      ( tup, cres ) <- bracket+        (traverse newCString args)+        (traverse_ free) $+        \cArgList -> do+          let cArgs = VS.fromList cArgList+          C.withPtr $ \tupp -> [C.exp| int {+            clang_parseTranslationUnit2(+              $(CXIndex idxp),+              $(char* cPath),+              $vec-ptr:(const char * const * cArgs), $vec-len:cArgs,+              NULL, 0,+              0,+              $(CXTranslationUnit *tupp))+            } |]       let res = parseClangError cres       when (res /= Success) $ throwIO res       return ( tup, clang_disposeTranslationUnit tup )@@ -131,10 +134,10 @@ withCXString :: (Ptr CXString -> IO ()) -> IO ByteString withCXString f = allocaBytes (#size CXString) $ \cxsp -> do   f cxsp-  cs <- [C.exp| const char * { clang_getCString(*$(CXString *cxsp)) } |]-  s <- BS.packCString cs-  [C.exp| void { clang_disposeString(*$(CXString *cxsp)) } |]-  return s+  bracket+    [C.exp| const char * { clang_getCString(*$(CXString *cxsp)) } |]+    (\_ -> [C.exp| void { clang_disposeString(*$(CXString *cxsp)) } |]) $+    \cs -> BS.packCString cs  cursorSpelling :: Cursor -> ByteString cursorSpelling c = uderef c $ \cp -> withCXString $ \cxsp ->@@ -607,3 +610,12 @@     "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)

@@ -343,3 +343,9 @@ type instance RefOf Token = CXToken type instance ParentOf Token = TranslationUnit data Token = Token TokenSet Int++data TypeLayoutError+  = TypeLayoutErrorInvalid+  | TypeLayoutErrorIncomplete+  | TypeLayoutErrorDependent+    deriving (Eq, Ord, Show)