diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 9999194ee..7fcbed674 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -22,10 +22,32 @@ import qualified Data.Syntax as Syntax import Data.Term import Prologue hiding (empty, packageName) +import Data.Aeson +import Data.Output +import Data.Text.Encoding as T +import Data.ByteString.Lazy (toStrict) + -- | The graph of function variableDefinitions to symbols used in a given program. newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Vertex } deriving (Eq, Graph, Show) +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) + +vertexToText :: Vertex -> Text +vertexToText = decodeUtf8 . vertexName + +vertexToType :: Vertex -> Text +vertexToType Package{..} = "package" +vertexToType Module{..} = "module" +vertexToType Variable{..} = "variable" + -- | A vertex of some specific type. data Vertex = Package { vertexName :: ByteString } @@ -33,6 +55,9 @@ data Vertex | Variable { vertexName :: ByteString } deriving (Eq, Ord, Show) +instance ToJSON Vertex where + toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ] + -- | Render a 'ImportGraph' to a 'ByteString' in DOT notation. renderImportGraph :: ImportGraph -> ByteString renderImportGraph = export style . unImportGraph diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index f20a400f6..7204ed132 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -2,6 +2,7 @@ module Rendering.Renderer ( DiffRenderer(..) , TermRenderer(..) +, GraphRenderer(..) , SomeRenderer(..) , renderSExpressionDiff , renderSExpressionTerm @@ -66,6 +67,13 @@ deriving instance Eq (TermRenderer output) deriving instance Show (TermRenderer output) +data GraphRenderer output where + JSONGraphRenderer :: GraphRenderer ByteString + DOTGraphRenderer :: GraphRenderer ByteString + +deriving instance Eq (GraphRenderer output) +deriving instance Show (GraphRenderer output) + -- | Abstraction of some renderer to some 'Monoid'al output which can be serialized to a 'ByteString'. -- -- This type abstracts the type indices of 'DiffRenderer' and 'TermRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f160f99b8..2966a5dc8 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -18,7 +18,8 @@ import qualified Paths_semantic as Library (version) import Semantic.IO (languageForFilePath) import qualified Semantic.Diff as Semantic (diffBlobPairs) import qualified Semantic.Log as Log -import qualified Semantic.Parse as Semantic (parseBlobs, graph) +import qualified Semantic.Parse as Semantic (parseBlobs) +import qualified Semantic.Graph as Semantic (graph) import qualified Semantic.Task as Task import System.IO (Handle, stdin, stdout) import Text.Read @@ -33,7 +34,7 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -runGraph :: SomeRenderer TermRenderer -> (FilePath, Maybe Language) -> Task.TaskEff ByteString +runGraph :: SomeRenderer GraphRenderer -> (FilePath, Maybe Language) -> Task.TaskEff ByteString runGraph (SomeRenderer r) = Semantic.graph r <=< Task.readBlob -- | A parser for the application's command-line arguments. @@ -89,7 +90,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute import/call graph for an entry point")) graphArgumentsParser = runGraph - <$> flag (SomeRenderer DOTTermRenderer) (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output in DOT graph format (default)") + <$> ( flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") + <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") + ) <*> argument filePathReader (metavar "ENTRY_FILE") filePathReader = eitherReader parseFilePath diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a81d547a0..e6db0735d 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -65,7 +65,6 @@ import Data.Abstract.Module import Data.Abstract.Package as Package import Data.Abstract.Value (Value) import Data.Blob -import qualified Data.ByteString as B import Data.Diff import qualified Data.Error as Error import Data.Record @@ -133,7 +132,7 @@ render :: Member Task effs => Renderer input output -> input -> Eff effs output render renderer = send . Render renderer --- | Render and serialize the import graph for a given 'Package'. +-- | Render the import graph for a given 'Package'. graphImports :: ( Show ann , Ord ann @@ -147,15 +146,14 @@ graphImports :: ( , Members '[Exc SomeException, Task] effs , term ~ Term (Union syntax) ann ) - => Package term -> Eff effs B.ByteString -graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= renderGraph + => Package term -> Eff effs Abstract.ImportGraph +graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph where asAnalysisForTypeOfPackage :: Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value -> Package term -> Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value asAnalysisForTypeOfPackage = const - renderGraph result = case result of - (Right (Right (Right (Right (Right (Right (_, graph)))))), _) -> pure $! Abstract.renderImportGraph graph - _ -> throwError (toException (Exc.ErrorCall "graphImports: import graph rendering failed")) - + extractGraph result = case result of + (Right (Right (Right (Right (Right (Right (_, graph)))))), _) -> pure $! graph + _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. --