diff --git a/app/FindClasses.hs b/app/FindClasses.hs --- a/app/FindClasses.hs +++ b/app/FindClasses.hs @@ -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 ) ) 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.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 diff --git a/examples/ListStructs.hs b/examples/ListStructs.hs new file mode 100644 --- /dev/null +++ b/examples/ListStructs.hs @@ -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]" diff --git a/examples/ListTypes.hs b/examples/ListTypes.hs --- a/examples/ListTypes.hs +++ b/examples/ListTypes.hs @@ -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)) diff --git a/src/Language/C/Clang/Cursor.hs b/src/Language/C/Clang/Cursor.hs --- a/src/Language/C/Clang/Cursor.hs +++ b/src/Language/C/Clang/Cursor.hs @@ -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 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 @@ -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 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 @@ -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) 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 @@ -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)