diff --git a/app/FindClasses.hs b/app/FindClasses.hs new file mode 100644 --- /dev/null +++ b/app/FindClasses.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import qualified Data.ByteString as BS +import Data.List +import qualified Data.HashMap.Strict as HMS +import Data.Hashable +import Language.C.Clang +import Language.C.Clang.Cursor +import Control.Lens +import Data.Traversable +import Data.Maybe +import GHC.Generics (Generic) +import System.Environment + +deriving instance Generic CursorKind +instance Hashable CursorKind + +classes :: [ ( String, Cursor -> Bool ) ] +classes = + [ ( "HasType", isJust . cursorType ) + , ( "HasChildren", notNullOf cursorChildrenF ) + , ( "HasExtent", isJust . cursorExtent ) + , ( "HasSpelling", not . BS.null . cursorSpelling ) + ] + +main :: IO () +main = do + args <- getArgs + case args of + [] -> putStrLn "usage: find-classes file1 [file2] [fileN...]" + + paths -> do + idx <- createIndex + + pathClassResults <- for paths $ \path -> do + tu <- parseTranslationUnit idx path [] + let root = translationUnitCursor tu + return $ HMS.fromList + [ ( className, findClass predicate root ) + | ( className, predicate ) <- classes + ] + + let classResults = foldl1' (HMS.unionWith (HMS.unionWith (&&))) pathClassResults + + let allInstances = + intercalate "\n" + [ instances + | ( className, kindResults ) <- HMS.toList classResults + , let sortedNames = sort [ show kind | ( kind, matches ) <- HMS.toList kindResults, matches ] + , let instances = unlines $ map (\kindName -> "instance " ++ className ++ " '" ++ kindName) sortedNames + ] + + putStrLn allInstances + +findClass :: (Cursor -> Bool) -> Cursor -> HMS.HashMap CursorKind Bool +findClass predicate root = HMS.fromListWith (&&) kindResults + where + kindResults = root ^.. cosmosOf cursorChildrenF . 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.1.0.3 +version: 0.2.0.0 synopsis: Pure C++ code analysis with libclang description: Pure C++ code analysis with libclang. @@ -13,9 +13,8 @@ copyright: Copyright 2014 Google Inc. All Rights Reserved. category: Language build-type: Custom --- extra-source-files: cabal-version: >=1.10 -extra-source-files: cbits/utils.h +extra-source-files: cbits/utils.h source-repository head type: git @@ -24,6 +23,7 @@ library exposed-modules: Language.C.Clang, Language.C.Clang.Cursor, + Language.C.Clang.Cursor.Typed, Language.C.Clang.File, Language.C.Clang.Location, Language.C.Clang.Token, @@ -44,16 +44,33 @@ FlexibleContexts build-depends: base >=4.8 && <5, contravariant >= 1.3.3, - inline-c >= 0.5.3.2, + inline-c >= 0.5.5.9, containers >= 0.5.6.2, template-haskell >= 2.10, vector >= 0.10.12, bytestring >= 0.10.6, - stm >= 2.4.4 + stm >= 2.4.4, + singletons >= 2.2, + microlens >= 0.4.7.0, + microlens-contra >= 0.1.0.1 hs-source-dirs: src/ build-tools: hsc2hs default-language: Haskell2010 include-dirs: cbits/ cc-options: -Wall extra-libraries: clang - ghc-options: -Wall -O2 + ghc-options: -Wall -O2 -fno-warn-redundant-constraints + +executable find-classes + main-is: FindClasses.hs + build-depends: base, clang-pure, lens, unordered-containers, hashable, bytestring + hs-source-dirs: app + buildable: False + ghc-options: -Wall -O2 -fno-warn-redundant-constraints -fno-warn-orphans + +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 -fno-warn-redundant-constraints diff --git a/examples/ListTypes.hs b/examples/ListTypes.hs new file mode 100644 --- /dev/null +++ b/examples/ListTypes.hs @@ -0,0 +1,49 @@ +{- +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 #-} + +import Language.C.Clang +import qualified Language.C.Clang.Cursor as UT +import Language.C.Clang.Cursor.Typed +import Data.Foldable +import Data.Function +import Control.Lens +import qualified Data.ByteString.Char8 as BS +import Data.Monoid +import System.Environment + +main :: IO () +main = do + args <- getArgs + case args of + path : clangArgs -> do + idx <- createIndex + tu <- parseTranslationUnit idx path clangArgs + let funDecs = + translationUnitCursor tu ^.. + cosmosOnOf cursorChildrenF UT.cursorChildrenF + . folding (matchKind @'FunctionDecl) + . to (\fd -> ( cursorSpelling fd, cursorType fd ) ) + for_ funDecs $ \( f, t ) -> putStrLn $ BS.unpack f ++ " :: " ++ BS.unpack (typeSpelling t) + + _ -> putStrLn "usage: list-fun-types path [clang opts]" diff --git a/src/Language/C/Clang.hs b/src/Language/C/Clang.hs --- a/src/Language/C/Clang.hs +++ b/src/Language/C/Clang.hs @@ -24,7 +24,6 @@ ClangOrd(..) ) where -import Language.C.Clang.Cursor as C import Language.C.Clang.File as C import Language.C.Clang.Location as C import Language.C.Clang.Token as C 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 @@ -14,8 +14,16 @@ limitations under the License. -} +{-| +Module : Language.C.Clang.Cursor +Copyright : (C) 2016 Patrick Chilton + +If you know what `CursorKind`s you want to operate on, +consider using "Language.C.Clang.Cursor.Typed" instead. +-} module Language.C.Clang.Cursor ( Cursor() + , translationUnitCursor , cursorTranslationUnit , cursorChildrenF , cursorChildren @@ -32,9 +40,7 @@ import Language.C.Clang.Internal.FFI import Language.C.Clang.Internal.Types -import Control.Applicative -import Data.Monoid +import Lens.Micro cursorChildren :: Cursor -> [ Cursor ] -cursorChildren - = (`appEndo` []) . getConst . cursorChildrenF (\c -> Const $ Endo (c:)) +cursorChildren = toListOf cursorChildrenF diff --git a/src/Language/C/Clang/Cursor/Typed.hs b/src/Language/C/Clang/Cursor/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Clang/Cursor/Typed.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +{-| +Module : Language.C.Clang.Cursor.Typed +Copyright : (C) 2016 Patrick Chilton + +This module contains a typed version of "Language.C.Clang.Cursor". +Here, we keep track of `CursorKind`s at type-level, which means +that you don't need to check whether a `Cursor` has a given property at runtime. +-} +module Language.C.Clang.Cursor.Typed + ( Cursor + , CursorK(..) + , matchKind + + , translationUnitCursor + + , cursorType + + , cursorChildrenF + , cursorChildren + + , cursorExtent + + , cursorSpelling + + , HasType + , HasChildren + , HasExtent + , HasSpelling + , CursorKind(..) + ) where + +import qualified Data.ByteString as BS +import Data.Functor.Contravariant +import Data.Maybe +import Data.Singletons +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 (CursorK(..)) + +-- | 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) +matchKind c + | cursorKind c == fromSing (sing :: Sing kind) = Just (CursorK c) + | otherwise = Nothing + +translationUnitCursor :: TranslationUnit -> CursorK 'TranslationUnit +translationUnitCursor = CursorK . UT.translationUnitCursor + +class HasType (kind :: CursorKind) +cursorType :: HasType kind => CursorK kind -> Type +cursorType = fromJust . UT.cursorType . withoutKind + +class HasChildren (kind :: CursorKind) + +to :: (s -> a) -> Getter s a +to k f = phantom . f . k + +cursorChildrenF :: HasChildren kind => Fold (CursorK kind) Cursor +cursorChildrenF = to withoutKind . UT.cursorChildrenF + +cursorChildren :: HasChildren kind => CursorK kind -> [ Cursor ] +cursorChildren = UT.cursorChildren . withoutKind + +class HasExtent (kind :: CursorKind) + +cursorExtent :: HasExtent kind => CursorK kind -> SourceRange +cursorExtent = fromJust . UT.cursorExtent . withoutKind + +class HasSpelling (kind :: CursorKind) + +cursorSpelling :: HasSpelling kind => CursorK kind -> BS.ByteString +cursorSpelling = UT.cursorSpelling . withoutKind + +-- instances derived experimentally with the find-classes executable +instance HasChildren 'ArraySubscriptExpr +instance HasChildren 'BinaryOperator +instance HasChildren 'CStyleCastExpr +instance HasChildren 'CXXBaseSpecifier +instance HasChildren 'CXXCatchStmt +instance HasChildren 'CXXConstCastExpr +instance HasChildren 'CXXDeleteExpr +instance HasChildren 'CXXDynamicCastExpr +instance HasChildren 'CXXFunctionalCastExpr +instance HasChildren 'CXXNewExpr +instance HasChildren 'CXXReinterpretCastExpr +instance HasChildren 'CXXStaticCastExpr +instance HasChildren 'CXXTryStmt +instance HasChildren 'CaseStmt +instance HasChildren 'ClassTemplate +instance HasChildren 'ClassTemplatePartialSpecialization +instance HasChildren 'CompoundAssignOperator +instance HasChildren 'ConditionalOperator +instance HasChildren 'DeclStmt +instance HasChildren 'DefaultStmt +instance HasChildren 'DoStmt +instance HasChildren 'EnumDecl +instance HasChildren 'ForStmt +instance HasChildren 'FunctionTemplate +instance HasChildren 'IfStmt +instance HasChildren 'InitListExpr +instance HasChildren 'ParenExpr +instance HasChildren 'SwitchStmt +instance HasChildren 'TranslationUnit +instance HasChildren 'UnaryOperator +instance HasChildren 'UnionDecl +instance HasChildren 'UsingDeclaration +instance HasChildren 'UsingDirective +instance HasChildren 'WhileStmt + +instance HasType 'ArraySubscriptExpr +instance HasType 'BinaryOperator +instance HasType 'CStyleCastExpr +instance HasType 'CXXBaseSpecifier +instance HasType 'CXXBoolLiteralExpr +instance HasType 'CXXConstCastExpr +instance HasType 'CXXDeleteExpr +instance HasType 'CXXDynamicCastExpr +instance HasType 'CXXFunctionalCastExpr +instance HasType 'CXXMethod +instance HasType 'CXXNewExpr +instance HasType 'CXXReinterpretCastExpr +instance HasType 'CXXStaticCastExpr +instance HasType 'CXXThisExpr +instance HasType 'CXXThrowExpr +instance HasType 'CallExpr +instance HasType 'CharacterLiteral +instance HasType 'ClassDecl +instance HasType 'ClassTemplatePartialSpecialization +instance HasType 'CompoundAssignOperator +instance HasType 'ConditionalOperator +instance HasType 'Constructor +instance HasType 'ConversionFunction +instance HasType 'DeclRefExpr +instance HasType 'Destructor +instance HasType 'EnumConstantDecl +instance HasType 'EnumDecl +instance HasType 'FieldDecl +instance HasType 'FloatingLiteral +instance HasType 'FunctionDecl +instance HasType 'FunctionTemplate +instance HasType 'GNUNullExpr +instance HasType 'InitListExpr +instance HasType 'IntegerLiteral +instance HasType 'MemberRef +instance HasType 'MemberRefExpr +instance HasType 'NonTypeTemplateParameter +instance HasType 'ParenExpr +instance HasType 'ParmDecl +instance HasType 'StringLiteral +instance HasType 'StructDecl +instance HasType 'TemplateTypeParameter +instance HasType 'TypeRef +instance HasType 'TypedefDecl +instance HasType 'UnaryOperator +instance HasType 'UnionDecl +instance HasType 'VarDecl + +instance HasExtent 'ArraySubscriptExpr +instance HasExtent 'AsmLabelAttr +instance HasExtent 'BinaryOperator +instance HasExtent 'BreakStmt +instance HasExtent 'CStyleCastExpr +instance HasExtent 'CXXAccessSpecifier +instance HasExtent 'CXXBaseSpecifier +instance HasExtent 'CXXBoolLiteralExpr +instance HasExtent 'CXXCatchStmt +instance HasExtent 'CXXConstCastExpr +instance HasExtent 'CXXDeleteExpr +instance HasExtent 'CXXDynamicCastExpr +instance HasExtent 'CXXFunctionalCastExpr +instance HasExtent 'CXXMethod +instance HasExtent 'CXXNewExpr +instance HasExtent 'CXXReinterpretCastExpr +instance HasExtent 'CXXStaticCastExpr +instance HasExtent 'CXXThisExpr +instance HasExtent 'CXXThrowExpr +instance HasExtent 'CXXTryStmt +instance HasExtent 'CallExpr +instance HasExtent 'CaseStmt +instance HasExtent 'CharacterLiteral +instance HasExtent 'ClassDecl +instance HasExtent 'ClassTemplate +instance HasExtent 'ClassTemplatePartialSpecialization +instance HasExtent 'CompoundAssignOperator +instance HasExtent 'CompoundStmt +instance HasExtent 'ConditionalOperator +instance HasExtent 'ConstAttr +instance HasExtent 'Constructor +instance HasExtent 'ContinueStmt +instance HasExtent 'ConversionFunction +instance HasExtent 'DeclRefExpr +instance HasExtent 'DeclStmt +instance HasExtent 'DefaultStmt +instance HasExtent 'Destructor +instance HasExtent 'DoStmt +instance HasExtent 'EnumConstantDecl +instance HasExtent 'EnumDecl +instance HasExtent 'FloatingLiteral +instance HasExtent 'ForStmt +instance HasExtent 'FunctionDecl +instance HasExtent 'FunctionTemplate +instance HasExtent 'GNUNullExpr +instance HasExtent 'IfStmt +instance HasExtent 'InitListExpr +instance HasExtent 'MemberRef +instance HasExtent 'MemberRefExpr +instance HasExtent 'Namespace +instance HasExtent 'NamespaceRef +instance HasExtent 'NonTypeTemplateParameter +instance HasExtent 'NullStmt +instance HasExtent 'OverloadedDeclRef +instance HasExtent 'ParenExpr +instance HasExtent 'PureAttr +instance HasExtent 'ReturnStmt +instance HasExtent 'StringLiteral +instance HasExtent 'StructDecl +instance HasExtent 'SwitchStmt +instance HasExtent 'TemplateRef +instance HasExtent 'TemplateTypeParameter +instance HasExtent 'TranslationUnit +instance HasExtent 'TypeRef +instance HasExtent 'TypedefDecl +instance HasExtent 'UnaryOperator +instance HasExtent 'UnionDecl +instance HasExtent 'UsingDeclaration +instance HasExtent 'UsingDirective +instance HasExtent 'WhileStmt + +instance HasSpelling 'AsmLabelAttr +instance HasSpelling 'CXXBaseSpecifier +instance HasSpelling 'CXXMethod +instance HasSpelling 'ClassDecl +instance HasSpelling 'ClassTemplate +instance HasSpelling 'ClassTemplatePartialSpecialization +instance HasSpelling 'Constructor +instance HasSpelling 'ConversionFunction +instance HasSpelling 'Destructor +instance HasSpelling 'EnumConstantDecl +instance HasSpelling 'FunctionDecl +instance HasSpelling 'FunctionTemplate +instance HasSpelling 'MemberRef +instance HasSpelling 'Namespace +instance HasSpelling 'NamespaceRef +instance HasSpelling 'OverloadedDeclRef +instance HasSpelling 'StringLiteral +instance HasSpelling 'TemplateRef +instance HasSpelling 'TranslationUnit +instance HasSpelling 'TypeRef +instance HasSpelling 'TypedefDecl +instance HasSpelling 'UsingDeclaration 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 @@ -14,7 +14,8 @@ limitations under the License. -} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-} +{-# LANGUAGE DataKinds #-} module Language.C.Clang.Internal.FFI where @@ -32,6 +33,7 @@ import qualified Language.C.Inline as CSafe import qualified Language.C.Inline.Unsafe as C import System.IO.Unsafe +import Lens.Micro.Contra import Language.C.Clang.Internal.Context import Language.C.Clang.Internal.Refs @@ -109,7 +111,7 @@ cursorKind c = uderef c $ fmap parseCursorKind . #peek CXCursor, kind -- | Fold over the children of a cursor in the `lens` sense. -cursorChildrenF :: (Applicative f, Contravariant f) => (Cursor -> f Cursor) -> (Cursor -> f Cursor) +cursorChildrenF :: Fold Cursor Cursor cursorChildrenF f c = uderef c $ \cp -> do -- initialize the "Fold state" with no effect fRef <- newIORef $ phantom $ pure () @@ -232,6 +234,8 @@ instance Eq Cursor where (==) = defaultEq $ \lp rp -> [C.exp| int { clang_equalCursors(*$(CXCursor *lp), *$(CXCursor *rp)) } |] + +deriving instance Eq (CursorK kind) instance Eq SourceRange where (==) = defaultEq $ \lp rp -> 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 @@ -14,8 +14,13 @@ limitations under the License. -} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} + module Language.C.Clang.Internal.Types where +import Data.Singletons.TH import Foreign import Language.C.Clang.Internal.Refs @@ -43,6 +48,10 @@ newtype Cursor = Cursor (Leaf TranslationUnit CXCursor) deriving (Child, Clang) +-- | A `Cursor` with a statically known `CursorKind`. +newtype CursorK (kind :: CursorKind) = CursorK { withoutKind :: Cursor } + deriving (Clang) + data CXSourceRange type instance RefOf SourceRange = CXSourceRange type instance ParentOf SourceRange = TranslationUnit @@ -267,6 +276,8 @@ | FirstExtraDecl | LastExtraDecl deriving (Eq, Ord, Show) + +genSingletons [''CursorKind] data TypeKind = Invalid diff --git a/src/Language/C/Clang/TranslationUnit.hs b/src/Language/C/Clang/TranslationUnit.hs --- a/src/Language/C/Clang/TranslationUnit.hs +++ b/src/Language/C/Clang/TranslationUnit.hs @@ -17,7 +17,6 @@ module Language.C.Clang.TranslationUnit ( TranslationUnit() , parseTranslationUnit - , translationUnitCursor ) where