mirror of
https://github.com/github/semantic.git
synced 2024-11-29 02:44:36 +03:00
Merge pull request #1803 from github/remove-call-graph
Add import-graph and call-graph commands
This commit is contained in:
Josh Vera
GitHub
commit
94f59c52b1
@ -16,15 +16,17 @@ library
|
||||
exposed-modules:
|
||||
-- Analyses & term annotations
|
||||
Analysis.Abstract.BadAddresses
|
||||
, Analysis.Abstract.BadSyntax
|
||||
, Analysis.Abstract.BadModuleResolutions
|
||||
, Analysis.Abstract.BadVariables
|
||||
, Analysis.Abstract.BadSyntax
|
||||
, Analysis.Abstract.BadValues
|
||||
, Analysis.Abstract.BadVariables
|
||||
, Analysis.Abstract.Caching
|
||||
, Analysis.Abstract.CallGraph
|
||||
, Analysis.Abstract.Collecting
|
||||
, Analysis.Abstract.Dead
|
||||
, Analysis.Abstract.Erroring
|
||||
, Analysis.Abstract.Evaluating
|
||||
, Analysis.Abstract.Graph
|
||||
, Analysis.Abstract.ImportGraph
|
||||
, Analysis.Abstract.Tracing
|
||||
, Analysis.Abstract.TypeChecking
|
||||
|
||||
49
src/Analysis/Abstract/CallGraph.hs
Normal file
49
src/Analysis/Abstract/CallGraph.hs
Normal file
@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.CallGraph ( CallGraphing ) where
|
||||
|
||||
import Analysis.Abstract.Graph
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Evaluatable (LoadError (..))
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Located
|
||||
import Data.Abstract.Module hiding (Module)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term
|
||||
import Prologue
|
||||
|
||||
newtype CallGraphing m (effects :: [* -> *]) a = CallGraphing { runCallGraphing :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (CallGraphing m)
|
||||
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, Member (State Graph) effects
|
||||
, Member Syntax.Identifier syntax
|
||||
, MonadAnalysis (Located location term) term value effects m
|
||||
, term ~ Term (Union syntax) ann
|
||||
)
|
||||
=> MonadAnalysis (Located location term) term value effects (CallGraphing m) where
|
||||
analyzeTerm eval term@(In _ syntax) = do
|
||||
case prj syntax of
|
||||
Just (Syntax.Identifier name) -> do
|
||||
moduleInclusion (Variable (unName name))
|
||||
variableDefinition name
|
||||
_ -> pure ()
|
||||
resume
|
||||
@(LoadError term)
|
||||
(liftAnalyze analyzeTerm eval term)
|
||||
(\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) >> yield [])
|
||||
|
||||
analyzeModule recur m = do
|
||||
let name = BC.pack (modulePath (moduleInfo m))
|
||||
packageInclusion (Module name)
|
||||
moduleInclusion (Module name)
|
||||
liftAnalyze analyzeModule recur m
|
||||
|
||||
instance Interpreter m effects
|
||||
=> Interpreter (CallGraphing m) (State Graph ': effects) where
|
||||
type Result (CallGraphing m) (State Graph ': effects) result = Result m effects (result, Graph)
|
||||
interpret = interpret . runCallGraphing . raiseHandler (`runState` mempty)
|
||||
138
src/Analysis/Abstract/Graph.hs
Normal file
138
src/Analysis/Abstract/Graph.hs
Normal file
@ -0,0 +1,138 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Graph
|
||||
( Graph(..)
|
||||
, Vertex(..)
|
||||
, renderGraph
|
||||
, appendGraph
|
||||
, variableDefinition
|
||||
, moduleInclusion
|
||||
, packageInclusion
|
||||
, packageGraph
|
||||
) where
|
||||
|
||||
import qualified Algebra.Graph as G
|
||||
import qualified Algebra.Graph.Class as GC
|
||||
import Algebra.Graph.Class hiding (Graph, Vertex)
|
||||
import Algebra.Graph.Export.Dot hiding (vertexName)
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Located
|
||||
import Data.Abstract.Module hiding (Module)
|
||||
import Data.Abstract.Origin hiding (Module, Package)
|
||||
import Data.Abstract.Package hiding (Package)
|
||||
import Data.Aeson hiding (Result)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.ByteString.Lazy (toStrict)
|
||||
import Data.Output
|
||||
import Data.Text.Encoding as T
|
||||
import Prologue hiding (empty, packageName)
|
||||
|
||||
-- | The graph of function variableDefinitions to symbols used in a given program.
|
||||
newtype Graph = Graph { unGraph :: G.Graph Vertex }
|
||||
deriving (Eq, GC.Graph, Show)
|
||||
|
||||
-- | A vertex of some specific type.
|
||||
data Vertex
|
||||
= Package { vertexName :: ByteString }
|
||||
| Module { vertexName :: ByteString }
|
||||
| Variable { vertexName :: ByteString }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Render a 'Graph' to a 'ByteString' in DOT notation.
|
||||
renderGraph :: Graph -> ByteString
|
||||
renderGraph = export style . unGraph
|
||||
|
||||
style :: Style Vertex ByteString
|
||||
style = (defaultStyle vertexName)
|
||||
{ vertexAttributes = vertexAttributes
|
||||
, edgeAttributes = edgeAttributes
|
||||
}
|
||||
where vertexAttributes Package{} = [ "style" := "dashed", "shape" := "box" ]
|
||||
vertexAttributes Module{} = [ "style" := "dotted, rounded", "shape" := "box" ]
|
||||
vertexAttributes Variable{} = []
|
||||
edgeAttributes Package{} Module{} = [ "style" := "dashed" ]
|
||||
edgeAttributes Module{} Variable{} = [ "style" := "dotted" ]
|
||||
edgeAttributes Variable{} Module{} = [ "color" := "blue" ]
|
||||
edgeAttributes _ _ = []
|
||||
|
||||
packageGraph :: SomeOrigin term -> Graph
|
||||
packageGraph = maybe empty (vertex . Package . unName . packageName) . withSomeOrigin originPackage
|
||||
|
||||
moduleGraph :: SomeOrigin term -> Graph
|
||||
moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOrigin originModule
|
||||
|
||||
-- | Add an edge from the current package to the passed vertex.
|
||||
packageInclusion :: forall m location term value effects
|
||||
. ( Member (State Graph) effects
|
||||
, MonadEvaluator location term value effects m
|
||||
)
|
||||
=> Vertex
|
||||
-> m effects ()
|
||||
packageInclusion v = do
|
||||
o <- raise ask
|
||||
appendGraph (packageGraph @term o `connect` vertex v)
|
||||
|
||||
-- | Add an edge from the current module to the passed vertex.
|
||||
moduleInclusion :: forall m location term value effects
|
||||
. ( Member (State Graph) effects
|
||||
, MonadEvaluator location term value effects m
|
||||
)
|
||||
=> Vertex
|
||||
-> m effects ()
|
||||
moduleInclusion v = do
|
||||
o <- raise ask
|
||||
appendGraph (moduleGraph @term o `connect` vertex v)
|
||||
|
||||
-- | Add an edge from the passed variable name to the module it originated within.
|
||||
variableDefinition :: ( Member (State Graph) effects
|
||||
, MonadEvaluator (Located location term) term value effects m
|
||||
)
|
||||
=> Name
|
||||
-> m effects ()
|
||||
variableDefinition name = do
|
||||
graph <- maybe empty (moduleGraph . origin . unAddress) <$> lookupEnv name
|
||||
appendGraph (vertex (Variable (unName name)) `connect` graph)
|
||||
|
||||
appendGraph :: (Effectful m, Member (State Graph) effects) => Graph -> m effects ()
|
||||
appendGraph = raise . modify' . (<>)
|
||||
|
||||
|
||||
instance Semigroup Graph where
|
||||
(<>) = overlay
|
||||
|
||||
instance Monoid Graph where
|
||||
mempty = empty
|
||||
mappend = (<>)
|
||||
|
||||
instance Ord Graph where
|
||||
compare (Graph G.Empty) (Graph G.Empty) = EQ
|
||||
compare (Graph G.Empty) _ = LT
|
||||
compare _ (Graph G.Empty) = GT
|
||||
compare (Graph (G.Vertex a)) (Graph (G.Vertex b)) = compare a b
|
||||
compare (Graph (G.Vertex _)) _ = LT
|
||||
compare _ (Graph (G.Vertex _)) = GT
|
||||
compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
|
||||
compare (Graph (G.Overlay _ _)) _ = LT
|
||||
compare _ (Graph (G.Overlay _ _)) = GT
|
||||
compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
|
||||
|
||||
instance Output Graph where
|
||||
toOutput = toStrict . (<> "\n") . encode
|
||||
|
||||
instance ToJSON Graph where
|
||||
toJSON Graph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
|
||||
where
|
||||
vertices = toJSON (G.vertexList unGraph)
|
||||
edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unGraph)
|
||||
|
||||
instance ToJSON Vertex where
|
||||
toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
|
||||
|
||||
vertexToText :: Vertex -> Text
|
||||
vertexToText = decodeUtf8 . vertexName
|
||||
|
||||
vertexToType :: Vertex -> Text
|
||||
vertexToType Package{} = "package"
|
||||
vertexToType Module{} = "module"
|
||||
vertexToType Variable{} = "variable"
|
||||
@ -1,57 +1,15 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.ImportGraph
|
||||
( ImportGraph(..)
|
||||
, renderImportGraph
|
||||
, ImportGraphing
|
||||
) where
|
||||
( ImportGraphing ) where
|
||||
|
||||
import qualified Algebra.Graph as G
|
||||
import Algebra.Graph.Class hiding (Vertex)
|
||||
import Algebra.Graph.Export.Dot hiding (vertexName)
|
||||
import Analysis.Abstract.Graph
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable (LoadError (..))
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Located
|
||||
import Data.Abstract.Module hiding (Module)
|
||||
import Data.Abstract.Origin hiding (Module, Package)
|
||||
import Data.Abstract.Package hiding (Package)
|
||||
import Data.Aeson hiding (Result)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.ByteString.Lazy (toStrict)
|
||||
import Data.Output
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term
|
||||
import Data.Text.Encoding as T
|
||||
import Prologue hiding (empty, packageName)
|
||||
|
||||
-- | The graph of function variableDefinitions to symbols used in a given program.
|
||||
newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Vertex }
|
||||
deriving (Eq, Graph, Show)
|
||||
|
||||
-- | A vertex of some specific type.
|
||||
data Vertex
|
||||
= Package { vertexName :: ByteString }
|
||||
| Module { vertexName :: ByteString }
|
||||
| Variable { vertexName :: ByteString }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Render a 'ImportGraph' to a 'ByteString' in DOT notation.
|
||||
renderImportGraph :: ImportGraph -> ByteString
|
||||
renderImportGraph = export style . unImportGraph
|
||||
|
||||
style :: Style Vertex ByteString
|
||||
style = (defaultStyle vertexName)
|
||||
{ vertexAttributes = vertexAttributes
|
||||
, edgeAttributes = edgeAttributes
|
||||
}
|
||||
where vertexAttributes Package{} = [ "style" := "dashed", "shape" := "box" ]
|
||||
vertexAttributes Module{} = [ "style" := "dotted, rounded", "shape" := "box" ]
|
||||
vertexAttributes Variable{} = []
|
||||
edgeAttributes Package{} Module{} = [ "style" := "dashed" ]
|
||||
edgeAttributes Module{} Variable{} = [ "style" := "dotted" ]
|
||||
edgeAttributes Variable{} Module{} = [ "color" := "blue" ]
|
||||
edgeAttributes _ _ = []
|
||||
import Prologue
|
||||
|
||||
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
@ -61,18 +19,12 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, Member (State ImportGraph) effects
|
||||
, Member Syntax.Identifier syntax
|
||||
, Member (State Graph) effects
|
||||
, MonadAnalysis (Located location term) term value effects m
|
||||
, term ~ Term (Union syntax) ann
|
||||
)
|
||||
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
|
||||
analyzeTerm eval term@(In _ syntax) = do
|
||||
case prj syntax of
|
||||
Just (Syntax.Identifier name) -> do
|
||||
moduleInclusion (Variable (unName name))
|
||||
variableDefinition name
|
||||
_ -> pure ()
|
||||
analyzeTerm eval term =
|
||||
resume
|
||||
@(LoadError term)
|
||||
(liftAnalyze analyzeTerm eval term)
|
||||
@ -84,89 +36,7 @@ instance ( Effectful m
|
||||
moduleInclusion (Module name)
|
||||
liftAnalyze analyzeModule recur m
|
||||
|
||||
packageGraph :: SomeOrigin term -> ImportGraph
|
||||
packageGraph = maybe empty (vertex . Package . unName . packageName) . withSomeOrigin originPackage
|
||||
|
||||
moduleGraph :: SomeOrigin term -> ImportGraph
|
||||
moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOrigin originModule
|
||||
|
||||
-- | Add an edge from the current package to the passed vertex.
|
||||
packageInclusion :: forall m location term value effects
|
||||
. ( Member (State ImportGraph) effects
|
||||
, MonadEvaluator location term value effects m
|
||||
)
|
||||
=> Vertex
|
||||
-> ImportGraphing m effects ()
|
||||
packageInclusion v = do
|
||||
o <- raise ask
|
||||
appendGraph (packageGraph @term o `connect` vertex v)
|
||||
|
||||
-- | Add an edge from the current module to the passed vertex.
|
||||
moduleInclusion :: forall m location term value effects
|
||||
. ( Member (State ImportGraph) effects
|
||||
, MonadEvaluator location term value effects m
|
||||
)
|
||||
=> Vertex
|
||||
-> ImportGraphing m effects ()
|
||||
moduleInclusion v = do
|
||||
o <- raise ask
|
||||
appendGraph (moduleGraph @term o `connect` vertex v)
|
||||
|
||||
-- | Add an edge from the passed variable name to the module it originated within.
|
||||
variableDefinition :: ( Member (State ImportGraph) effects
|
||||
, MonadEvaluator (Located location term) term value effects m
|
||||
)
|
||||
=> Name
|
||||
-> ImportGraphing m effects ()
|
||||
variableDefinition name = do
|
||||
graph <- maybe empty (moduleGraph . origin . unAddress) <$> lookupEnv name
|
||||
appendGraph (vertex (Variable (unName name)) `connect` graph)
|
||||
|
||||
appendGraph :: (Effectful m, Member (State ImportGraph) effects) => ImportGraph -> ImportGraphing m effects ()
|
||||
appendGraph = raise . modify' . (<>)
|
||||
|
||||
|
||||
instance Semigroup ImportGraph where
|
||||
(<>) = overlay
|
||||
|
||||
instance Monoid ImportGraph where
|
||||
mempty = empty
|
||||
mappend = (<>)
|
||||
|
||||
instance Ord ImportGraph where
|
||||
compare (ImportGraph G.Empty) (ImportGraph G.Empty) = EQ
|
||||
compare (ImportGraph G.Empty) _ = LT
|
||||
compare _ (ImportGraph G.Empty) = GT
|
||||
compare (ImportGraph (G.Vertex a)) (ImportGraph (G.Vertex b)) = compare a b
|
||||
compare (ImportGraph (G.Vertex _)) _ = LT
|
||||
compare _ (ImportGraph (G.Vertex _)) = GT
|
||||
compare (ImportGraph (G.Overlay a1 a2)) (ImportGraph (G.Overlay b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
|
||||
compare (ImportGraph (G.Overlay _ _)) _ = LT
|
||||
compare _ (ImportGraph (G.Overlay _ _)) = GT
|
||||
compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
|
||||
|
||||
instance Output ImportGraph where
|
||||
toOutput = toStrict . (<> "\n") . encode
|
||||
|
||||
instance ToJSON ImportGraph where
|
||||
toJSON ImportGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
|
||||
where
|
||||
vertices = toJSON (G.vertexList unImportGraph)
|
||||
edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unImportGraph)
|
||||
|
||||
instance ToJSON Vertex where
|
||||
toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
|
||||
|
||||
vertexToText :: Vertex -> Text
|
||||
vertexToText = decodeUtf8 . vertexName
|
||||
|
||||
vertexToType :: Vertex -> Text
|
||||
vertexToType Package{} = "package"
|
||||
vertexToType Module{} = "module"
|
||||
vertexToType Variable{} = "variable"
|
||||
|
||||
|
||||
instance Interpreter m effects
|
||||
=> Interpreter (ImportGraphing m) (State ImportGraph ': effects) where
|
||||
type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph)
|
||||
=> Interpreter (ImportGraphing m) (State Graph ': effects) where
|
||||
type Result (ImportGraphing m) (State Graph ': effects) result = Result m effects (result, Graph)
|
||||
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)
|
||||
|
||||
@ -24,14 +24,14 @@ module Rendering.Renderer
|
||||
, defaultSymbolFields
|
||||
) where
|
||||
|
||||
import Prologue
|
||||
import Data.Aeson (Value)
|
||||
import Data.Output
|
||||
import Prologue
|
||||
import Rendering.DOT as R
|
||||
import Rendering.Imports as R
|
||||
import Rendering.JSON as R
|
||||
import Rendering.SExpression as R
|
||||
import Rendering.Symbol as R
|
||||
import Rendering.Imports as R
|
||||
import Rendering.TOC as R
|
||||
|
||||
-- | Specification of renderers for diffs, producing output in the parameter type.
|
||||
|
||||
@ -17,7 +17,7 @@ import qualified Paths_semantic as Library (version)
|
||||
import Prologue
|
||||
import Rendering.Renderer
|
||||
import qualified Semantic.Diff as Semantic (diffBlobPairs)
|
||||
import qualified Semantic.Graph as Semantic (graph)
|
||||
import Semantic.Graph as Semantic (graph, GraphType(..))
|
||||
import Semantic.IO (languageForFilePath)
|
||||
import qualified Semantic.Log as Log
|
||||
import qualified Semantic.Parse as Semantic (parseBlobs)
|
||||
@ -34,8 +34,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
|
||||
runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
|
||||
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
||||
|
||||
runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
|
||||
runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs
|
||||
runGraph :: Semantic.GraphType -> SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
|
||||
runGraph graphType (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph graphType r <=< Task.readProject rootDir dir excludeDirs
|
||||
|
||||
-- | A parser for the application's command-line arguments.
|
||||
--
|
||||
@ -84,15 +84,19 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||
pure $ runParse renderer filesOrStdin
|
||||
|
||||
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
|
||||
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point"))
|
||||
graphArgumentsParser = do
|
||||
graphType <- flag ImportGraph ImportGraph (long "imports" <> help "Compute an import graph")
|
||||
<|> flag' CallGraph (long "calls" <> help "Compute a call graph")
|
||||
renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)")
|
||||
<|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
|
||||
rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
|
||||
excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
|
||||
rootDir <- rootDirectoryOption
|
||||
excludeDirs <- excludeDirsOption
|
||||
File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
|
||||
pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
|
||||
pure $ runGraph graphType renderer rootDir filePath (fromJust fileLanguage) excludeDirs
|
||||
|
||||
rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
|
||||
excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
|
||||
filePathReader = eitherReader parseFilePath
|
||||
parseFilePath arg = case splitWhen (== ':') arg of
|
||||
[a, b] | lang <- readMaybe b -> Right (File a lang)
|
||||
|
||||
@ -9,6 +9,8 @@ import Analysis.Abstract.BadVariables
|
||||
import Analysis.Abstract.Erroring
|
||||
import Analysis.Abstract.Evaluating
|
||||
import Analysis.Abstract.ImportGraph
|
||||
import Analysis.Abstract.CallGraph
|
||||
import Analysis.Abstract.Graph (Graph, renderGraph)
|
||||
import qualified Control.Exception as Exc
|
||||
import Data.Abstract.Address
|
||||
import qualified Data.Abstract.Evaluatable as Analysis
|
||||
@ -27,16 +29,23 @@ import Rendering.Renderer
|
||||
import Semantic.IO (Files)
|
||||
import Semantic.Task
|
||||
|
||||
data GraphType = ImportGraph | CallGraph
|
||||
|
||||
graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
|
||||
=> GraphRenderer output
|
||||
=> GraphType
|
||||
-> GraphRenderer output
|
||||
-> Project
|
||||
-> Eff effs ByteString
|
||||
graph renderer project
|
||||
graph graphType renderer project
|
||||
| SomeAnalysisParser parser prelude <- someAnalysisParser
|
||||
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
|
||||
parsePackage parser prelude project >>= graphImports >>= case renderer of
|
||||
package <- parsePackage parser prelude project
|
||||
let graph = case graphType of
|
||||
ImportGraph -> graphImports
|
||||
CallGraph -> graphCalls
|
||||
graph package >>= case renderer of
|
||||
JSONGraphRenderer -> pure . toOutput
|
||||
DOTGraphRenderer -> pure . renderImportGraph
|
||||
DOTGraphRenderer -> pure . renderGraph
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||
@ -61,10 +70,8 @@ parseModule parser rootDir file = do
|
||||
blob <- readBlob file
|
||||
moduleForBlob rootDir blob <$> parse parser blob
|
||||
|
||||
|
||||
type ImportGraphAnalysis term
|
||||
= ImportGraphing
|
||||
( BadAddresses
|
||||
type GraphAnalysis term
|
||||
= BadAddresses
|
||||
( BadModuleResolutions
|
||||
( BadVariables
|
||||
( BadValues
|
||||
@ -73,10 +80,30 @@ type ImportGraphAnalysis term
|
||||
( Evaluating
|
||||
(Located Precise term)
|
||||
term
|
||||
(Value (Located Precise term)))))))))
|
||||
(Value (Located Precise term))))))))
|
||||
|
||||
-- | Render the import graph for a given 'Package'.
|
||||
graphImports :: ( Show ann
|
||||
, Ord ann
|
||||
, Apply Analysis.Declarations1 syntax
|
||||
, Apply Analysis.Evaluatable syntax
|
||||
, Apply FreeVariables1 syntax
|
||||
, Apply Functor syntax
|
||||
, Apply Ord1 syntax
|
||||
, Apply Eq1 syntax
|
||||
, Apply Show1 syntax
|
||||
, Members '[Exc SomeException, Task] effs
|
||||
)
|
||||
=> Package (Term (Union syntax) ann) -> Eff effs Graph
|
||||
graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
|
||||
where
|
||||
asAnalysisForTypeOfPackage :: ImportGraphing (GraphAnalysis term) effs value
|
||||
-> Package term
|
||||
-> ImportGraphing (GraphAnalysis term) effs value
|
||||
asAnalysisForTypeOfPackage = const
|
||||
|
||||
-- | Render the call graph for a given 'Package'.
|
||||
graphCalls :: ( Show ann
|
||||
, Ord ann
|
||||
, Apply Analysis.Declarations1 syntax
|
||||
, Apply Analysis.Evaluatable syntax
|
||||
@ -88,14 +115,17 @@ graphImports :: ( Show ann
|
||||
, Member Syntax.Identifier syntax
|
||||
, Members '[Exc SomeException, Task] effs
|
||||
)
|
||||
=> Package (Term (Union syntax) ann) -> Eff effs ImportGraph
|
||||
graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
|
||||
=> Package (Term (Union syntax) ann) -> Eff effs Graph
|
||||
graphCalls package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
|
||||
where
|
||||
asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
|
||||
asAnalysisForTypeOfPackage :: CallGraphing (GraphAnalysis term) effs value
|
||||
-> Package term
|
||||
-> ImportGraphAnalysis term effs value
|
||||
-> CallGraphing (GraphAnalysis term) effs value
|
||||
asAnalysisForTypeOfPackage = const
|
||||
|
||||
extractGraph result = case result of
|
||||
extractGraph :: (Show a, Show b, Show result, Show c, Show err, Show aux, Member (Exc SomeException) e)
|
||||
=> (Either err (Either a ((b, result), c)), aux)
|
||||
-> Eff e result
|
||||
extractGraph result = case result of
|
||||
(Right (Right ((_, graph), _)), _) -> pure graph
|
||||
_ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
|
||||
err -> throwError (toException (Exc.ErrorCall ("extractGraph: graph rendering failed " <> show err)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user