1
1
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:
Josh Vera 2018-05-02 15:07:01 -04:00 committed by GitHub
commit 94f59c52b1
7 changed files with 260 additions and 167 deletions

View File

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

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

View 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"

View File

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

View File

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

View File

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

View File

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