From 1f2e2345494272fe8bd82dc31ef7ea77f615e7e5 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 1 May 2018 17:51:24 -0400 Subject: [PATCH] Add CallGraph --- semantic.cabal | 1 + src/Analysis/Abstract/CallGraph.hs | 172 +++++++++++++++++++++++++++++ 2 files changed, 173 insertions(+) create mode 100644 src/Analysis/Abstract/CallGraph.hs diff --git a/semantic.cabal b/semantic.cabal index aed7305bd..829da8763 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -25,6 +25,7 @@ library , Analysis.Abstract.Dead , Analysis.Abstract.Erroring , Analysis.Abstract.Evaluating + , Analysis.Abstract.CallGraph , Analysis.Abstract.ImportGraph , Analysis.Abstract.Tracing , Analysis.Abstract.TypeChecking diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs new file mode 100644 index 000000000..2739a025d --- /dev/null +++ b/src/Analysis/Abstract/CallGraph.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +module Analysis.Abstract.CallGraph +( CallGraph(..) +, renderCallGraph +, CallGraphing +) where + +import qualified Algebra.Graph as G +import Algebra.Graph.Class hiding (Vertex) +import Algebra.Graph.Export.Dot hiding (vertexName) +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 CallGraph = CallGraph { unCallGraph :: 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 'CallGraph' to a 'ByteString' in DOT notation. +renderCallGraph :: CallGraph -> ByteString +renderCallGraph = export style . unCallGraph + +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 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 CallGraph) 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 + +packageGraph :: SomeOrigin term -> CallGraph +packageGraph = maybe empty (vertex . Package . unName . packageName) . withSomeOrigin originPackage + +moduleGraph :: SomeOrigin term -> CallGraph +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 CallGraph) effects + , MonadEvaluator location term value effects m + ) + => Vertex + -> CallGraphing 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 CallGraph) effects + , MonadEvaluator location term value effects m + ) + => Vertex + -> CallGraphing 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 CallGraph) effects + , MonadEvaluator (Located location term) term value effects m + ) + => Name + -> CallGraphing 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 CallGraph) effects) => CallGraph -> CallGraphing m effects () +appendGraph = raise . modify' . (<>) + + +instance Semigroup CallGraph where + (<>) = overlay + +instance Monoid CallGraph where + mempty = empty + mappend = (<>) + +instance Ord CallGraph where + compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ + compare (CallGraph G.Empty) _ = LT + compare _ (CallGraph G.Empty) = GT + compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b + compare (CallGraph (G.Vertex _)) _ = LT + compare _ (CallGraph (G.Vertex _)) = GT + compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + compare (CallGraph (G.Overlay _ _)) _ = LT + compare _ (CallGraph (G.Overlay _ _)) = GT + compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + +instance Output CallGraph where + toOutput = toStrict . (<> "\n") . encode + +instance ToJSON CallGraph where + toJSON CallGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ] + where + vertices = toJSON (G.vertexList unCallGraph) + edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unCallGraph) + +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 (CallGraphing m) (State CallGraph ': effects) where + type Result (CallGraphing m) (State CallGraph ': effects) result = Result m effects (result, CallGraph) + interpret = interpret . runCallGraphing . raiseHandler (`runState` mempty)