mirror of
https://github.com/github/semantic.git
synced 2024-11-29 11:02:26 +03:00
Merge pull request #1803 from github/remove-call-graph
Add import-graph and call-graph commands
This commit is contained in:
commit
94f59c52b1
@ -16,15 +16,17 @@ library
|
|||||||
exposed-modules:
|
exposed-modules:
|
||||||
-- Analyses & term annotations
|
-- Analyses & term annotations
|
||||||
Analysis.Abstract.BadAddresses
|
Analysis.Abstract.BadAddresses
|
||||||
, Analysis.Abstract.BadSyntax
|
|
||||||
, Analysis.Abstract.BadModuleResolutions
|
, Analysis.Abstract.BadModuleResolutions
|
||||||
, Analysis.Abstract.BadVariables
|
, Analysis.Abstract.BadSyntax
|
||||||
, Analysis.Abstract.BadValues
|
, Analysis.Abstract.BadValues
|
||||||
|
, Analysis.Abstract.BadVariables
|
||||||
, Analysis.Abstract.Caching
|
, Analysis.Abstract.Caching
|
||||||
|
, Analysis.Abstract.CallGraph
|
||||||
, Analysis.Abstract.Collecting
|
, Analysis.Abstract.Collecting
|
||||||
, Analysis.Abstract.Dead
|
, Analysis.Abstract.Dead
|
||||||
, Analysis.Abstract.Erroring
|
, Analysis.Abstract.Erroring
|
||||||
, Analysis.Abstract.Evaluating
|
, Analysis.Abstract.Evaluating
|
||||||
|
, Analysis.Abstract.Graph
|
||||||
, Analysis.Abstract.ImportGraph
|
, Analysis.Abstract.ImportGraph
|
||||||
, Analysis.Abstract.Tracing
|
, Analysis.Abstract.Tracing
|
||||||
, Analysis.Abstract.TypeChecking
|
, 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 #-}
|
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Analysis.Abstract.ImportGraph
|
module Analysis.Abstract.ImportGraph
|
||||||
( ImportGraph(..)
|
( ImportGraphing ) where
|
||||||
, renderImportGraph
|
|
||||||
, ImportGraphing
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Algebra.Graph as G
|
import Analysis.Abstract.Graph
|
||||||
import Algebra.Graph.Class hiding (Vertex)
|
|
||||||
import Algebra.Graph.Export.Dot hiding (vertexName)
|
|
||||||
import Control.Abstract.Analysis
|
import Control.Abstract.Analysis
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Evaluatable (LoadError (..))
|
import Data.Abstract.Evaluatable (LoadError (..))
|
||||||
import Data.Abstract.FreeVariables
|
|
||||||
import Data.Abstract.Located
|
import Data.Abstract.Located
|
||||||
import Data.Abstract.Module hiding (Module)
|
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 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.Term
|
||||||
import Data.Text.Encoding as T
|
import Prologue
|
||||||
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 _ _ = []
|
|
||||||
|
|
||||||
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
|
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
|
||||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||||
@ -61,18 +19,12 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator
|
|||||||
|
|
||||||
instance ( Effectful m
|
instance ( Effectful m
|
||||||
, Member (Resumable (LoadError term)) effects
|
, Member (Resumable (LoadError term)) effects
|
||||||
, Member (State ImportGraph) effects
|
, Member (State Graph) effects
|
||||||
, Member Syntax.Identifier syntax
|
|
||||||
, MonadAnalysis (Located location term) term value effects m
|
, MonadAnalysis (Located location term) term value effects m
|
||||||
, term ~ Term (Union syntax) ann
|
, term ~ Term (Union syntax) ann
|
||||||
)
|
)
|
||||||
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
|
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
|
||||||
analyzeTerm eval term@(In _ syntax) = do
|
analyzeTerm eval term =
|
||||||
case prj syntax of
|
|
||||||
Just (Syntax.Identifier name) -> do
|
|
||||||
moduleInclusion (Variable (unName name))
|
|
||||||
variableDefinition name
|
|
||||||
_ -> pure ()
|
|
||||||
resume
|
resume
|
||||||
@(LoadError term)
|
@(LoadError term)
|
||||||
(liftAnalyze analyzeTerm eval term)
|
(liftAnalyze analyzeTerm eval term)
|
||||||
@ -84,89 +36,7 @@ instance ( Effectful m
|
|||||||
moduleInclusion (Module name)
|
moduleInclusion (Module name)
|
||||||
liftAnalyze analyzeModule recur m
|
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
|
instance Interpreter m effects
|
||||||
=> Interpreter (ImportGraphing m) (State ImportGraph ': effects) where
|
=> Interpreter (ImportGraphing m) (State Graph ': effects) where
|
||||||
type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph)
|
type Result (ImportGraphing m) (State Graph ': effects) result = Result m effects (result, Graph)
|
||||||
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)
|
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)
|
||||||
|
@ -24,14 +24,14 @@ module Rendering.Renderer
|
|||||||
, defaultSymbolFields
|
, defaultSymbolFields
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson (Value)
|
import Data.Aeson (Value)
|
||||||
import Data.Output
|
import Data.Output
|
||||||
|
import Prologue
|
||||||
import Rendering.DOT as R
|
import Rendering.DOT as R
|
||||||
|
import Rendering.Imports as R
|
||||||
import Rendering.JSON as R
|
import Rendering.JSON as R
|
||||||
import Rendering.SExpression as R
|
import Rendering.SExpression as R
|
||||||
import Rendering.Symbol as R
|
import Rendering.Symbol as R
|
||||||
import Rendering.Imports as R
|
|
||||||
import Rendering.TOC as R
|
import Rendering.TOC as R
|
||||||
|
|
||||||
-- | Specification of renderers for diffs, producing output in the parameter type.
|
-- | Specification of renderers for diffs, producing output in the parameter type.
|
||||||
@ -69,7 +69,7 @@ deriving instance Show (TermRenderer output)
|
|||||||
-- | Specification of renderers for graph analysis, producing output in the parameter type.
|
-- | Specification of renderers for graph analysis, producing output in the parameter type.
|
||||||
data GraphRenderer output where
|
data GraphRenderer output where
|
||||||
JSONGraphRenderer :: GraphRenderer ByteString
|
JSONGraphRenderer :: GraphRenderer ByteString
|
||||||
DOTGraphRenderer :: GraphRenderer ByteString
|
DOTGraphRenderer :: GraphRenderer ByteString
|
||||||
|
|
||||||
deriving instance Eq (GraphRenderer output)
|
deriving instance Eq (GraphRenderer output)
|
||||||
deriving instance Show (GraphRenderer output)
|
deriving instance Show (GraphRenderer output)
|
||||||
|
@ -17,7 +17,7 @@ import qualified Paths_semantic as Library (version)
|
|||||||
import Prologue
|
import Prologue
|
||||||
import Rendering.Renderer
|
import Rendering.Renderer
|
||||||
import qualified Semantic.Diff as Semantic (diffBlobPairs)
|
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 Semantic.IO (languageForFilePath)
|
||||||
import qualified Semantic.Log as Log
|
import qualified Semantic.Log as Log
|
||||||
import qualified Semantic.Parse as Semantic (parseBlobs)
|
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 TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
|
||||||
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
||||||
|
|
||||||
runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
|
runGraph :: Semantic.GraphType -> 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 graphType (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph graphType r <=< Task.readProject rootDir dir excludeDirs
|
||||||
|
|
||||||
-- | A parser for the application's command-line arguments.
|
-- | 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)
|
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||||
pure $ runParse renderer filesOrStdin
|
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
|
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)")
|
renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)")
|
||||||
<|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
|
<|> 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"))
|
rootDir <- rootDirectoryOption
|
||||||
excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
|
excludeDirs <- excludeDirsOption
|
||||||
File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
|
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
|
filePathReader = eitherReader parseFilePath
|
||||||
parseFilePath arg = case splitWhen (== ':') arg of
|
parseFilePath arg = case splitWhen (== ':') arg of
|
||||||
[a, b] | lang <- readMaybe b -> Right (File a lang)
|
[a, b] | lang <- readMaybe b -> Right (File a lang)
|
||||||
|
@ -9,6 +9,8 @@ import Analysis.Abstract.BadVariables
|
|||||||
import Analysis.Abstract.Erroring
|
import Analysis.Abstract.Erroring
|
||||||
import Analysis.Abstract.Evaluating
|
import Analysis.Abstract.Evaluating
|
||||||
import Analysis.Abstract.ImportGraph
|
import Analysis.Abstract.ImportGraph
|
||||||
|
import Analysis.Abstract.CallGraph
|
||||||
|
import Analysis.Abstract.Graph (Graph, renderGraph)
|
||||||
import qualified Control.Exception as Exc
|
import qualified Control.Exception as Exc
|
||||||
import Data.Abstract.Address
|
import Data.Abstract.Address
|
||||||
import qualified Data.Abstract.Evaluatable as Analysis
|
import qualified Data.Abstract.Evaluatable as Analysis
|
||||||
@ -27,16 +29,23 @@ import Rendering.Renderer
|
|||||||
import Semantic.IO (Files)
|
import Semantic.IO (Files)
|
||||||
import Semantic.Task
|
import Semantic.Task
|
||||||
|
|
||||||
|
data GraphType = ImportGraph | CallGraph
|
||||||
|
|
||||||
graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
|
graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
|
||||||
=> GraphRenderer output
|
=> GraphType
|
||||||
|
-> GraphRenderer output
|
||||||
-> Project
|
-> Project
|
||||||
-> Eff effs ByteString
|
-> Eff effs ByteString
|
||||||
graph renderer project
|
graph graphType renderer project
|
||||||
| SomeAnalysisParser parser prelude <- someAnalysisParser
|
| SomeAnalysisParser parser prelude <- someAnalysisParser
|
||||||
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
|
(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
|
||||||
JSONGraphRenderer -> pure . toOutput
|
let graph = case graphType of
|
||||||
DOTGraphRenderer -> pure . renderImportGraph
|
ImportGraph -> graphImports
|
||||||
|
CallGraph -> graphCalls
|
||||||
|
graph package >>= case renderer of
|
||||||
|
JSONGraphRenderer -> pure . toOutput
|
||||||
|
DOTGraphRenderer -> pure . renderGraph
|
||||||
|
|
||||||
-- | Parse a list of files into a 'Package'.
|
-- | Parse a list of files into a 'Package'.
|
||||||
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||||
@ -61,10 +70,8 @@ parseModule parser rootDir file = do
|
|||||||
blob <- readBlob file
|
blob <- readBlob file
|
||||||
moduleForBlob rootDir blob <$> parse parser blob
|
moduleForBlob rootDir blob <$> parse parser blob
|
||||||
|
|
||||||
|
type GraphAnalysis term
|
||||||
type ImportGraphAnalysis term
|
= BadAddresses
|
||||||
= ImportGraphing
|
|
||||||
( BadAddresses
|
|
||||||
( BadModuleResolutions
|
( BadModuleResolutions
|
||||||
( BadVariables
|
( BadVariables
|
||||||
( BadValues
|
( BadValues
|
||||||
@ -73,10 +80,30 @@ type ImportGraphAnalysis term
|
|||||||
( Evaluating
|
( Evaluating
|
||||||
(Located Precise term)
|
(Located Precise term)
|
||||||
term
|
term
|
||||||
(Value (Located Precise term)))))))))
|
(Value (Located Precise term))))))))
|
||||||
|
|
||||||
-- | Render the import graph for a given 'Package'.
|
-- | Render the import graph for a given 'Package'.
|
||||||
graphImports :: ( Show ann
|
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
|
, Ord ann
|
||||||
, Apply Analysis.Declarations1 syntax
|
, Apply Analysis.Declarations1 syntax
|
||||||
, Apply Analysis.Evaluatable syntax
|
, Apply Analysis.Evaluatable syntax
|
||||||
@ -88,14 +115,17 @@ graphImports :: ( Show ann
|
|||||||
, Member Syntax.Identifier syntax
|
, Member Syntax.Identifier syntax
|
||||||
, Members '[Exc SomeException, Task] effs
|
, Members '[Exc SomeException, Task] effs
|
||||||
)
|
)
|
||||||
=> Package (Term (Union syntax) ann) -> Eff effs ImportGraph
|
=> Package (Term (Union syntax) ann) -> Eff effs Graph
|
||||||
graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
|
graphCalls package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
|
||||||
where
|
where
|
||||||
asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
|
asAnalysisForTypeOfPackage :: CallGraphing (GraphAnalysis term) effs value
|
||||||
-> Package term
|
-> Package term
|
||||||
-> ImportGraphAnalysis term effs value
|
-> CallGraphing (GraphAnalysis term) effs value
|
||||||
asAnalysisForTypeOfPackage = const
|
asAnalysisForTypeOfPackage = const
|
||||||
|
|
||||||
extractGraph result = case result of
|
extractGraph :: (Show a, Show b, Show result, Show c, Show err, Show aux, Member (Exc SomeException) e)
|
||||||
(Right (Right ((_, graph), _)), _) -> pure graph
|
=> (Either err (Either a ((b, result), c)), aux)
|
||||||
_ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
|
-> Eff e result
|
||||||
|
extractGraph result = case result of
|
||||||
|
(Right (Right ((_, graph), _)), _) -> pure graph
|
||||||
|
err -> throwError (toException (Exc.ErrorCall ("extractGraph: graph rendering failed " <> show err)))
|
||||||
|
Loading…
Reference in New Issue
Block a user