diff --git a/semantic.cabal b/semantic.cabal index 97ab049a3..0f9db0c4c 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -140,6 +140,7 @@ library , Semantic.CLI , Semantic.Diff , Semantic.Distribute + , Semantic.Graph , Semantic.IO , Semantic.Log , Semantic.Parse diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 9999194ee..bd9f0ca3a 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/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" diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 91471222f..5341fe54a 100644 --- a/src/Parsing/Parser.hs +++ b/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 diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index f20a400f6..2118f3e2b 100644 --- a/src/Rendering/Renderer.hs +++ b/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 diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 60df96e4d..9919626b4 100644 --- a/src/Semantic/CLI.hs +++ b/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) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs new file mode 100644 index 000000000..45013b86e --- /dev/null +++ b/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 diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index be7b494ab..c7a3140c0 100644 --- a/src/Semantic/IO.hs +++ b/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) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index e4287c4d0..0df70fe7e 100644 --- a/src/Semantic/Task.hs +++ b/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'. -- diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b9208fd88..a382cabb8 100644 --- a/src/Semantic/Util.hs +++ b/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