Merge pull request #1724 from github/graph-cli

Wire up graph analysis to the CLI

semantic.cabal

@@ -140,6 +140,7 @@ library
                      , Semantic.CLI
                      , Semantic.Diff
                      , Semantic.Distribute
+                     , Semantic.Graph
                      , Semantic.IO
                      , Semantic.Log
                      , Semantic.Parse

src/Analysis/Abstract/ImportGraph.hs

@@ -17,9 +17,13 @@ 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
 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.
@@ -151,3 +155,23 @@ instance Ord ImportGraph where
   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"

src/Parsing/Parser.hs

@@ -2,8 +2,11 @@
 module Parsing.Parser
 ( Parser(..)
 , SomeParser(..)
+, SomeAnalysisParser(..)
 , someParser
+, someAnalysisParser
 , ApplyAll
+, ApplyAll'
 -- À la carte parsers
 , goParser
 , jsonParser
@@ -14,30 +17,65 @@ module Parsing.Parser
 , phpParser
 ) where
 
-import Prologue
-import Assigning.Assignment
+import           Assigning.Assignment
 import qualified CMarkGFM
-import Data.AST
-import Data.Kind
-import Data.Language
-import Data.Record
+import           Data.AST
+import           Data.Kind
+import           Data.Language
+import           Data.Record
 import qualified Data.Syntax as Syntax
-import Data.Term
-import Foreign.Ptr
+import           Data.Term
+import           Foreign.Ptr
+import qualified GHC.TypeLits as TypeLevel
 import qualified Language.Go.Assignment as Go
 import qualified Language.JSON.Assignment as JSON
 import qualified Language.Markdown.Assignment as Markdown
+import qualified Language.PHP.Assignment as PHP
+import           Language.Preluded
 import qualified Language.Python.Assignment as Python
 import qualified Language.Ruby.Assignment as Ruby
 import qualified Language.TypeScript.Assignment as TypeScript
-import qualified Language.PHP.Assignment as PHP
+import           Prologue
+import           TreeSitter.Go
+import           TreeSitter.JSON
 import qualified TreeSitter.Language as TS (Language, Symbol)
-import TreeSitter.Go
-import TreeSitter.JSON
-import TreeSitter.PHP
-import TreeSitter.Python
-import TreeSitter.Ruby
-import TreeSitter.TypeScript
+import           TreeSitter.PHP
+import           TreeSitter.Python
+import           TreeSitter.Ruby
+import           TreeSitter.TypeScript
+
+
+type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where
+  ApplyAll' (typeclass ': typeclasses) fs = (Apply typeclass fs, ApplyAll' typeclasses fs)
+  ApplyAll' '[] fs = ()
+
+-- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
+data SomeAnalysisParser typeclasses ann where
+  SomeAnalysisParser :: ( Member Syntax.Identifier fs
+                        , ApplyAll' typeclasses fs)
+                     => Parser (Term (Union fs) ann) -- ^ A parser.
+                     -> [String]                     -- ^ List of valid file extensions to be used for module resolution.
+                     -> Maybe String                 -- ^ Maybe path to prelude.
+                     -> SomeAnalysisParser typeclasses ann
+
+-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
+someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
+                      , ApplyAll' typeclasses PHP.Syntax
+                      , ApplyAll' typeclasses Python.Syntax
+                      , ApplyAll' typeclasses Ruby.Syntax
+                      , ApplyAll' typeclasses TypeScript.Syntax
+                      )
+                   => proxy typeclasses                                -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
+                   -> Language                                         -- ^ The 'Language' to select.
+                   -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced.
+someAnalysisParser _ Go         = SomeAnalysisParser goParser ["go"] Nothing
+someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser ["js"] Nothing
+someAnalysisParser _ PHP        = SomeAnalysisParser phpParser ["php"] Nothing
+someAnalysisParser _ Python     = SomeAnalysisParser pythonParser ["py"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))))
+someAnalysisParser _ Ruby       = SomeAnalysisParser rubyParser ["rb"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))))
+someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser ["ts", "tsx", "d.tsx"] Nothing
+someAnalysisParser _ l          = error $ "Analysis not supported for: " <> show l
+
 
 -- | A parser from 'Source' onto some term type.
 data Parser term where

src/Rendering/Renderer.hs

@@ -2,6 +2,7 @@
 module Rendering.Renderer
 ( DiffRenderer(..)
 , TermRenderer(..)
+, GraphRenderer(..)
 , SomeRenderer(..)
 , renderSExpressionDiff
 , renderSExpressionTerm
@@ -65,10 +66,17 @@ data TermRenderer output where
 deriving instance Eq (TermRenderer output)
 deriving instance Show (TermRenderer output)
 
+-- | Specification of renderers for graph analysis, producing output in the parameter type.
+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.)
+--   This type abstracts the type indices of 'DiffRenderer', 'TermRenderer', and 'GraphRenderer' 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.)
 data SomeRenderer f where
   SomeRenderer :: (Output output, Show (f output)) => f output -> SomeRenderer f
 

src/Semantic/CLI.hs

@@ -19,6 +19,7 @@ import Semantic.IO (languageForFilePath)
 import qualified Semantic.Diff as Semantic (diffBlobPairs)
 import qualified Semantic.Log as Log
 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,6 +34,9 @@ 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 GraphRenderer -> (FilePath, Maybe Language) -> Task.TaskEff ByteString
+runGraph (SomeRenderer r) = Semantic.graph r <=< Task.readBlob
+
 -- | A parser for the application's command-line arguments.
 --
 --   Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
@@ -55,7 +59,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       <*> pure 0 -- ProcessID
       <*> switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
     argumentsParser = (. Task.writeToOutput) . (>>=)
-      <$> hsubparser (diffCommand <> parseCommand)
+      <$> hsubparser (diffCommand <> parseCommand <> graphCommand)
       <*> (   Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
           <|> pure (Left stdout) )
 
@@ -85,6 +89,13 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       <*> (   Right <$> some (argument filePathReader (metavar "FILES..."))
           <|> pure (Left stdin) )
 
+    graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute import/call graph for an entry point"))
+    graphArgumentsParser = runGraph
+      <$> (   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
     parseFilePath arg = case splitWhen (== ':') arg of
         [a, b] | Just lang <- readMaybe a -> Right (b, Just lang)

src/Semantic/Graph.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs, ScopedTypeVariables #-}
+module Semantic.Graph where
+
+import qualified Analysis.Abstract.ImportGraph as Abstract
+import qualified Data.Abstract.Evaluatable as Analysis
+import           Data.Abstract.FreeVariables
+import           Data.Blob
+import           Data.ByteString.Char8 as BC (pack)
+import           Data.Output
+import           Parsing.Parser
+import           Prologue hiding (MonadError (..))
+import           Rendering.Renderer
+import           Semantic.IO (Files, NoLanguageForBlob (..))
+import           Semantic.Task
+import           System.FilePath.Posix
+
+graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException] effs) => GraphRenderer output -> Blob -> Eff effs ByteString
+graph renderer Blob{..}
+  | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser
+    (Proxy :: Proxy '[ Analysis.Evaluatable, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do
+    let rootDir = takeDirectory blobPath
+    paths <- filter (/= blobPath) <$> listFiles rootDir exts
+    prelude <- traverse (parseModule parser Nothing) preludePath
+    package <- parsePackage (packageName blobPath) parser rootDir (blobPath : paths)
+    graphImports prelude package >>= case renderer of
+      JSONGraphRenderer -> pure . toOutput
+      DOTGraphRenderer -> pure . Abstract.renderImportGraph
+
+  | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
+
+  where packageName = name . BC.pack . dropExtensions . takeFileName

src/Semantic/IO.hs

@@ -9,6 +9,8 @@ module Semantic.IO
 , readBlobsFromDir
 , languageForFilePath
 , NoLanguageForBlob(..)
+, listFiles
+, readBlob
 , readBlobs
 , readBlobPairs
 , writeToOutput
@@ -75,6 +77,11 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
 readBlobsFromHandle = fmap toBlobs . readFromHandle
   where toBlobs BlobParse{..} = fmap toBlob blobs
 
+readBlobFromPath :: MonadIO m => (FilePath, Maybe Language) -> m Blob.Blob
+readBlobFromPath file = do
+  maybeFile <- uncurry readFile file
+  maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile
+
 readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
 readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files
 
@@ -129,6 +136,11 @@ instance FromJSON BlobPair where
 newtype NoLanguageForBlob = NoLanguageForBlob FilePath
   deriving (Eq, Exception, Ord, Show, Typeable)
 
+listFiles :: Member Files effs => FilePath -> [String] -> Eff effs [FilePath]
+listFiles dir exts = send (ListFiles dir exts)
+
+readBlob :: Member Files effs => (FilePath, Maybe Language) -> Eff effs Blob.Blob
+readBlob = send . ReadBlob
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
 readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob]
@@ -145,6 +157,9 @@ writeToOutput path = send . WriteToOutput path
 
 -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
 data Files out where
+  ReadBlob      :: (FilePath, Maybe Language) -> Files Blob.Blob
+  ListFiles     :: FilePath -> [String] -> Files [FilePath]
+
   ReadBlobs     :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob]
   ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair]
   WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
@@ -152,6 +167,9 @@ data Files out where
 -- | Run a 'Files' effect in 'IO'.
 runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
 runFiles = interpret $ \ files -> case files of
+  ReadBlob path -> rethrowing (readBlobFromPath path)
+  ListFiles directory exts -> liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) directory)
+
   ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
   ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
   ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)

src/Semantic/Task.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( Task
 , TaskEff
@@ -7,6 +7,8 @@ module Semantic.Task
 , RAlgebra
 , Differ
 -- * I/O
+, IO.listFiles
+, IO.readBlob
 , IO.readBlobs
 , IO.readBlobPairs
 , IO.writeToOutput
@@ -45,8 +47,12 @@ module Semantic.Task
 , Telemetry
 ) where
 
-import qualified Analysis.Abstract.ImportGraph as Abstract
+import           Analysis.Abstract.BadModuleResolutions
+import           Analysis.Abstract.BadValues
+import           Analysis.Abstract.BadVariables
 import           Analysis.Abstract.Evaluating
+import qualified Analysis.Abstract.ImportGraph as Abstract
+import           Analysis.Abstract.Quiet
 import           Analysis.Decorator (decoratorWithAlgebra)
 import qualified Assigning.Assignment as Assignment
 import qualified Control.Abstract.Analysis as Analysis
@@ -64,7 +70,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
@@ -73,7 +78,7 @@ import           Data.Term
 import           Parsing.CMark
 import           Parsing.Parser
 import           Parsing.TreeSitter
-import           Prologue hiding (MonadError(..))
+import           Prologue hiding (MonadError (..))
 import           Semantic.Distribute
 import qualified Semantic.IO as IO
 import           Semantic.Log
@@ -132,16 +137,42 @@ 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'.
-graphImports :: (Apply Eq1 syntax, Apply Analysis.Evaluatable syntax, Apply FreeVariables1 syntax, Apply Functor syntax, Apply Ord1 syntax, Apply Show1 syntax, Member Syntax.Identifier syntax, Members '[Exc SomeException, Task] effs, Ord ann, Show ann) => Package (Term (Union syntax) ann) -> Eff effs B.ByteString
-graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= renderGraph
-  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
+type ImportGraphAnalysis term effects value =
+  Abstract.ImportGraphing
+    (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))
+    effects
+    value
 
-        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"))
+-- | Render the import graph for a given 'Package'.
+graphImports :: (
+                  Show ann
+                , Ord ann
+                , Apply Analysis.Evaluatable syntax
+                , Apply FreeVariables1 syntax
+                , Apply Functor syntax
+                , Apply Ord1 syntax
+                , Apply Eq1 syntax
+                , Apply Show1 syntax
+                , Member Syntax.Identifier syntax
+                , Members '[Exc SomeException, Task] effs
+                , term ~ Term (Union syntax) ann
+                )
+             => Maybe (Module term) -> Package term -> Eff effs Abstract.ImportGraph
+graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelude (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package))) >>= extractGraph
+  where
+    asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
+                               -> Package term
+                               -> ImportGraphAnalysis term effs value
+    asAnalysisForTypeOfPackage = const
 
+    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)))
+
+    withPrelude Nothing a = a
+    withPrelude (Just prelude) a = do
+      preludeEnv <- Analysis.evaluateModule prelude *> Analysis.getEnv
+      Analysis.withDefaultEnvironment preludeEnv a
 
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --

src/Semantic/Util.hs

@@ -37,7 +37,7 @@ import Parsing.Parser
 import Prologue
 import Semantic.Diff (diffTermPair)
 import Semantic.IO as IO
-import Semantic.Task hiding (parsePackage)
+import Semantic.Task
 import qualified Semantic.Task as Task
 import System.FilePath.Posix
 
@@ -65,8 +65,7 @@ typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Typ
 -- Python
 evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"]
 evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path))
-
-evalPythonImportGraph name paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))) . evaluatePackage <$> parsePackage name pythonParser (dropFileName (head paths)) paths
+evalPythonProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))))))) <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluatePackageBody <$> parseProject pythonParser ["py"] path))
 
 typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
 tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path