Add imports and calls flags to graph

src/Rendering/Renderer.hs

@@ -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.
@@ -68,10 +68,8 @@ deriving instance Show (TermRenderer output)
 
 -- | Specification of renderers for graph analysis, producing output in the parameter type.
 data GraphRenderer output where
-  JSONImportGraphRenderer :: GraphRenderer ByteString
-  DOTImportGraphRenderer :: GraphRenderer ByteString
-  JSONCallGraphRenderer :: GraphRenderer ByteString
-  DOTCallGraphRenderer :: GraphRenderer ByteString
+  JSONGraphRenderer :: GraphRenderer ByteString
+  DOTGraphRenderer  :: GraphRenderer ByteString
 
 deriving instance Eq (GraphRenderer output)
 deriving instance Show (GraphRenderer output)

src/Semantic/CLI.hs

@@ -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.
 --
@@ -56,7 +56,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning
 
     argumentsParser = do
-      subparser <- hsubparser (diffCommand <> parseCommand <> importGraphCommand <> callGraphCommand)
+      subparser <- hsubparser (diffCommand <> parseCommand <> graphCommand)
       output <- Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout)
       pure $ subparser >>= Task.writeToOutput output
 
@@ -84,23 +84,16 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
       pure $ runParse renderer filesOrStdin
 
-    importGraphCommand = command "import-graph" (info importGraphArgumentsParser (progDesc "Compute an import graph for a directory or entry point"))
-    importGraphArgumentsParser = do
-      renderer <- flag (SomeRenderer DOTImportGraphRenderer) (SomeRenderer DOTImportGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
-              <|> flag'                                (SomeRenderer JSONImportGraphRenderer) (long "json" <> help "Output JSON graph")
+    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 <- rootDirectoryOption
       excludeDirs <- excludeDirsOption
       File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
-      pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
-
-    callGraphCommand = command "call-graph" (info callGraphArgumentsParser (progDesc "Compute a call graph for a directory or entry point"))
-    callGraphArgumentsParser = do
-      renderer <- flag (SomeRenderer DOTCallGraphRenderer) (SomeRenderer DOTCallGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
-              <|> flag'                                (SomeRenderer JSONCallGraphRenderer) (long "json" <> help "Output JSON graph")
-      rootDir <- rootDirectoryOption
-      excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
-      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)"))

src/Semantic/Graph.hs

@@ -29,22 +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
     package <- parsePackage parser prelude project
-    let graph = case renderer of
-          JSONCallGraphRenderer -> graphCalls
-          DOTCallGraphRenderer  -> graphCalls
-          _                     -> graphImports
+    let graph = case graphType of
+          ImportGraph -> graphImports
+          CallGraph   -> graphCalls
     graph package >>= case renderer of
-      JSONCallGraphRenderer   -> pure . toOutput
-      JSONImportGraphRenderer -> pure . toOutput
-      _                       -> pure . renderGraph
+      JSONGraphRenderer   -> pure . toOutput
+      DOTGraphRenderer    -> pure . renderGraph
 
 -- | Parse a list of files into a 'Package'.
 parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs