clang-pure 0.1.0.3 → 0.2.0.0

raw patch · 9 files changed

+421/−14 lines, 9 filesdep +clang-puredep +hashabledep +lensdep ~basedep ~bytestringdep ~inline-cnew-component:exe:find-classesnew-component:exe:list-fun-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: clang-pure, hashable, lens, microlens, microlens-contra, singletons, unordered-containers

Dependency ranges changed: base, bytestring, inline-c

API changes (from Hackage documentation)

Files

• app/FindClasses.hs +61/−0
• clang-pure.cabal +23/−6
• examples/ListTypes.hs +49/−0
• src/Language/C/Clang.hs +0/−1
• src/Language/C/Clang/Cursor.hs +10/−4
• src/Language/C/Clang/Cursor/Typed.hs +261/−0
• src/Language/C/Clang/Internal/FFI.hsc +6/−2
• src/Language/C/Clang/Internal/Types.hs +11/−0
• src/Language/C/Clang/TranslationUnit.hs +0/−1

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

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

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

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

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

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

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

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

@@ -17,7 +17,6 @@ module Language.C.Clang.TranslationUnit   ( TranslationUnit()   , parseTranslationUnit-  , translationUnitCursor   ) where