mirror of
https://github.com/github/semantic.git
synced 2024-12-01 09:15:01 +03:00
Merge branch 'master' into scope-effects-to-evaluation
This commit is contained in:
Rob Rix
commit
4f69f5e3de
@ -19,7 +19,7 @@ library
|
||||
, Analysis.Abstract.Collecting
|
||||
, Analysis.Abstract.Dead
|
||||
, Analysis.Abstract.Evaluating
|
||||
, Analysis.Abstract.ImportGraph
|
||||
, Analysis.Abstract.Graph
|
||||
, Analysis.Abstract.Tracing
|
||||
, Analysis.CallGraph
|
||||
, Analysis.ConstructorName
|
||||
|
||||
@ -1,15 +1,22 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.ImportGraph
|
||||
( ImportGraph(..)
|
||||
, renderImportGraph
|
||||
module Analysis.Abstract.Graph
|
||||
( Graph(..)
|
||||
, Vertex(..)
|
||||
, renderGraph
|
||||
, appendGraph
|
||||
, variableDefinition
|
||||
, moduleInclusion
|
||||
, packageInclusion
|
||||
, packageGraph
|
||||
, graphingTerms
|
||||
, graphingLoadErrors
|
||||
, graphingModules
|
||||
, importGraphing
|
||||
, graphing
|
||||
) where
|
||||
|
||||
import qualified Algebra.Graph as G
|
||||
import Algebra.Graph.Class hiding (Vertex)
|
||||
import qualified Algebra.Graph.Class as GC
|
||||
import Algebra.Graph.Class hiding (Graph, Vertex)
|
||||
import Algebra.Graph.Export.Dot hiding (vertexName)
|
||||
import Control.Abstract.Evaluator
|
||||
import Data.Abstract.Address
|
||||
@ -28,21 +35,21 @@ import Data.Text.Encoding as T
|
||||
import Prologue hiding (empty, packageName)
|
||||
|
||||
-- | The graph of function variableDefinitions to symbols used in a given program.
|
||||
newtype ImportGraph term = ImportGraph { unImportGraph :: G.Graph (Vertex term) }
|
||||
deriving (Eq, Graph, Show)
|
||||
newtype Graph = Graph { unGraph :: G.Graph Vertex }
|
||||
deriving (Eq, GC.Graph, Show)
|
||||
|
||||
-- | A vertex of some specific type.
|
||||
data Vertex term
|
||||
data Vertex
|
||||
= Package { vertexName :: ByteString }
|
||||
| Module { vertexName :: ByteString }
|
||||
| Variable { vertexName :: ByteString }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Render a 'ImportGraph' to a 'ByteString' in DOT notation.
|
||||
renderImportGraph :: ImportGraph term -> ByteString
|
||||
renderImportGraph = export style . unImportGraph
|
||||
-- | Render a 'Graph' to a 'ByteString' in DOT notation.
|
||||
renderGraph :: Graph -> ByteString
|
||||
renderGraph = export style . unGraph
|
||||
|
||||
style :: Style (Vertex term) ByteString
|
||||
style :: Style Vertex ByteString
|
||||
style = (defaultStyle vertexName)
|
||||
{ vertexAttributes = vertexAttributes
|
||||
, edgeAttributes = edgeAttributes
|
||||
@ -55,12 +62,13 @@ style = (defaultStyle vertexName)
|
||||
edgeAttributes Variable{} Module{} = [ "color" := "blue" ]
|
||||
edgeAttributes _ _ = []
|
||||
|
||||
|
||||
graphingTerms :: ( Element Syntax.Identifier syntax
|
||||
, Members '[ Reader (Environment (Located location) value)
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, State (Environment (Located location) value)
|
||||
, State (ImportGraph term)
|
||||
, State Graph
|
||||
] effects
|
||||
, term ~ Term (Sum syntax) ann
|
||||
)
|
||||
@ -77,7 +85,7 @@ graphingTerms recur term@(In _ syntax) = do
|
||||
graphingLoadErrors :: forall location term value effects a
|
||||
. Members '[ Reader ModuleInfo
|
||||
, Resumable (LoadError term)
|
||||
, State (ImportGraph term)
|
||||
, State Graph
|
||||
] effects
|
||||
=> SubtermAlgebra (Base term) term (Evaluator location term value effects a)
|
||||
-> SubtermAlgebra (Base term) term (Evaluator location term value effects a)
|
||||
@ -87,7 +95,7 @@ graphingLoadErrors recur term = resume @(LoadError term)
|
||||
|
||||
graphingModules :: Members '[ Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, State (ImportGraph term)
|
||||
, State Graph
|
||||
] effects
|
||||
=> SubtermAlgebra Module term (Evaluator location term value effects a)
|
||||
-> SubtermAlgebra Module term (Evaluator location term value effects a)
|
||||
@ -98,28 +106,34 @@ graphingModules recur m = do
|
||||
recur m
|
||||
|
||||
|
||||
packageGraph :: PackageInfo -> ImportGraph term
|
||||
packageGraph :: PackageInfo -> Graph
|
||||
packageGraph = vertex . Package . unName . packageName
|
||||
|
||||
moduleGraph :: ModuleInfo -> ImportGraph term
|
||||
moduleGraph :: ModuleInfo -> Graph
|
||||
moduleGraph = vertex . Module . BC.pack . modulePath
|
||||
|
||||
-- | Add an edge from the current package to the passed vertex.
|
||||
packageInclusion :: Members '[ Reader PackageInfo
|
||||
, State (ImportGraph term)
|
||||
] effects
|
||||
=> Vertex term
|
||||
-> Evaluator location term value effects ()
|
||||
packageInclusion :: ( Effectful m
|
||||
, Members '[ Reader PackageInfo
|
||||
, State Graph
|
||||
] effects
|
||||
, Monad (m effects)
|
||||
)
|
||||
=> Vertex
|
||||
-> m effects ()
|
||||
packageInclusion v = do
|
||||
p <- currentPackage
|
||||
appendGraph (packageGraph p `connect` vertex v)
|
||||
|
||||
-- | Add an edge from the current module to the passed vertex.
|
||||
moduleInclusion :: Members '[ Reader ModuleInfo
|
||||
, State (ImportGraph term)
|
||||
] effects
|
||||
=> Vertex term
|
||||
-> Evaluator location term value effects ()
|
||||
moduleInclusion :: ( Effectful m
|
||||
, Members '[ Reader ModuleInfo
|
||||
, State Graph
|
||||
] effects
|
||||
, Monad (m effects)
|
||||
)
|
||||
=> Vertex
|
||||
-> m effects ()
|
||||
moduleInclusion v = do
|
||||
m <- currentModule
|
||||
appendGraph (moduleGraph m `connect` vertex v)
|
||||
@ -127,7 +141,7 @@ moduleInclusion v = do
|
||||
-- | Add an edge from the passed variable name to the module it originated within.
|
||||
variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects
|
||||
, Member (State (Environment (Located location) value)) effects
|
||||
, Member (State (ImportGraph term)) effects
|
||||
, Member (State Graph) effects
|
||||
)
|
||||
=> Name
|
||||
-> Evaluator (Located location) term value effects ()
|
||||
@ -135,49 +149,49 @@ variableDefinition name = do
|
||||
graph <- maybe empty (moduleGraph . locationModule . unAddress) <$> lookupEnv name
|
||||
appendGraph (vertex (Variable (unName name)) `connect` graph)
|
||||
|
||||
appendGraph :: Member (State (ImportGraph term)) effects => ImportGraph term -> Evaluator location term value effects ()
|
||||
appendGraph :: (Effectful m, Member (State Graph) effects) => Graph -> m effects ()
|
||||
appendGraph = raise . modify' . (<>)
|
||||
|
||||
|
||||
instance Semigroup (ImportGraph term) where
|
||||
instance Semigroup Graph where
|
||||
(<>) = overlay
|
||||
|
||||
instance Monoid (ImportGraph term) where
|
||||
instance Monoid Graph where
|
||||
mempty = empty
|
||||
mappend = (<>)
|
||||
|
||||
instance Ord (ImportGraph term) where
|
||||
compare (ImportGraph G.Empty) (ImportGraph G.Empty) = EQ
|
||||
compare (ImportGraph G.Empty) _ = LT
|
||||
compare _ (ImportGraph G.Empty) = GT
|
||||
compare (ImportGraph (G.Vertex a)) (ImportGraph (G.Vertex b)) = compare a b
|
||||
compare (ImportGraph (G.Vertex _)) _ = LT
|
||||
compare _ (ImportGraph (G.Vertex _)) = GT
|
||||
compare (ImportGraph (G.Overlay a1 a2)) (ImportGraph (G.Overlay b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
|
||||
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 Ord Graph where
|
||||
compare (Graph G.Empty) (Graph G.Empty) = EQ
|
||||
compare (Graph G.Empty) _ = LT
|
||||
compare _ (Graph G.Empty) = GT
|
||||
compare (Graph (G.Vertex a)) (Graph (G.Vertex b)) = compare a b
|
||||
compare (Graph (G.Vertex _)) _ = LT
|
||||
compare _ (Graph (G.Vertex _)) = GT
|
||||
compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
|
||||
compare (Graph (G.Overlay _ _)) _ = LT
|
||||
compare _ (Graph (G.Overlay _ _)) = GT
|
||||
compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
|
||||
|
||||
instance Output (ImportGraph term) where
|
||||
instance Output Graph where
|
||||
toOutput = toStrict . (<> "\n") . encode
|
||||
|
||||
instance ToJSON (ImportGraph term) where
|
||||
toJSON ImportGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
|
||||
instance ToJSON Graph where
|
||||
toJSON Graph{..} = 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)
|
||||
vertices = toJSON (G.vertexList unGraph)
|
||||
edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unGraph)
|
||||
|
||||
instance ToJSON (Vertex term) where
|
||||
instance ToJSON Vertex where
|
||||
toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
|
||||
|
||||
vertexToText :: Vertex termt -> Text
|
||||
vertexToText :: Vertex -> Text
|
||||
vertexToText = decodeUtf8 . vertexName
|
||||
|
||||
vertexToType :: Vertex termt -> Text
|
||||
vertexToType :: Vertex -> Text
|
||||
vertexToType Package{} = "package"
|
||||
vertexToType Module{} = "module"
|
||||
vertexToType Variable{} = "variable"
|
||||
|
||||
|
||||
importGraphing :: Effectful m => m (State (ImportGraph term) ': effects) result -> m effects (result, ImportGraph term)
|
||||
importGraphing = runState mempty
|
||||
graphing :: Effectful m => m (State Graph ': effects) result -> m effects (result, Graph)
|
||||
graphing = runState mempty
|
||||
@ -252,11 +252,11 @@ modifyModuleTable = raise . modify'
|
||||
-- Context
|
||||
|
||||
-- | Get the currently evaluating 'ModuleInfo'.
|
||||
currentModule :: Member (Reader ModuleInfo) effects => Evaluator location term value effects ModuleInfo
|
||||
currentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => m effects ModuleInfo
|
||||
currentModule = raise ask
|
||||
|
||||
-- | Get the currently evaluating 'PackageInfo'.
|
||||
currentPackage :: Member (Reader PackageInfo) effects => Evaluator location term value effects PackageInfo
|
||||
currentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => m effects PackageInfo
|
||||
currentPackage = raise ask
|
||||
|
||||
|
||||
|
||||
@ -6,6 +6,11 @@ import Data.Record
|
||||
import Data.Span
|
||||
import Data.Term
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Char8 (pack)
|
||||
import Data.JSON.Fields
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
|
||||
-- | An AST node labelled with symbols and source location.
|
||||
type AST syntax grammar = Term syntax (Node grammar)
|
||||
|
||||
@ -16,6 +21,12 @@ data Node grammar = Node
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
instance Show grammar => ToJSONFields (Node grammar) where
|
||||
toJSONFields Node{..} =
|
||||
[ "symbol" .= decodeUtf8 (pack (show nodeSymbol))
|
||||
, "span" .= nodeSpan ]
|
||||
|
||||
-- | A location specified as possibly-empty intervals of bytes and line/column positions.
|
||||
type Location = '[Range, Span]
|
||||
|
||||
|
||||
@ -3,7 +3,9 @@ module Parsing.Parser
|
||||
( Parser(..)
|
||||
, SomeParser(..)
|
||||
, SomeAnalysisParser(..)
|
||||
, SomeASTParser(..)
|
||||
, someParser
|
||||
, someASTParser
|
||||
, someAnalysisParser
|
||||
, ApplyAll
|
||||
, ApplyAll'
|
||||
@ -148,3 +150,21 @@ typescriptParser = AssignmentParser (ASTParser tree_sitter_typescript) TypeScrip
|
||||
|
||||
markdownParser :: Parser Markdown.Term
|
||||
markdownParser = AssignmentParser MarkdownParser Markdown.assignment
|
||||
|
||||
|
||||
-- | A parser for producing specialized (tree-sitter) ASTs.
|
||||
data SomeASTParser where
|
||||
SomeASTParser :: forall grammar. (Bounded grammar, Enum grammar, Show grammar)
|
||||
=> Parser (AST [] grammar)
|
||||
-> SomeASTParser
|
||||
|
||||
someASTParser :: Language -> SomeASTParser
|
||||
someASTParser Go = SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar))
|
||||
someASTParser JavaScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))
|
||||
someASTParser JSON = SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar))
|
||||
someASTParser JSX = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))
|
||||
someASTParser Python = SomeASTParser (ASTParser tree_sitter_python :: Parser (AST [] Python.Grammar))
|
||||
someASTParser Ruby = SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar))
|
||||
someASTParser TypeScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))
|
||||
someASTParser PHP = SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar))
|
||||
someASTParser l = error $ "Tree-Sitter AST parsing not supported for: " <> show l
|
||||
|
||||
@ -2,6 +2,7 @@ module Rendering.JSON
|
||||
( renderJSONDiff
|
||||
, renderJSONDiffs
|
||||
, renderJSONTerm
|
||||
, renderJSONTerm'
|
||||
, renderJSONTerms
|
||||
) where
|
||||
|
||||
@ -29,5 +30,8 @@ renderJSONDiffs = Map.singleton "diffs" . toJSON
|
||||
renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
|
||||
renderJSONTerm blob content = pure $ toJSON (object ("programNode" .= content : toJSONFields blob))
|
||||
|
||||
renderJSONTerm' :: (ToJSON a) => Blob -> a -> [Value]
|
||||
renderJSONTerm' blob content = pure $ toJSON (object ("ast" .= content : toJSONFields blob))
|
||||
|
||||
renderJSONTerms :: [Value] -> Map.Map Text Value
|
||||
renderJSONTerms = Map.singleton "trees" . toJSON
|
||||
|
||||
@ -6,9 +6,11 @@ module Rendering.Renderer
|
||||
, SomeRenderer(..)
|
||||
, renderSExpressionDiff
|
||||
, renderSExpressionTerm
|
||||
, renderSExpressionAST
|
||||
, renderJSONDiff
|
||||
, renderJSONDiffs
|
||||
, renderJSONTerm
|
||||
, renderJSONTerm'
|
||||
, renderJSONTerms
|
||||
, renderToCDiff
|
||||
, renderToCTerm
|
||||
@ -24,14 +26,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.
|
||||
@ -69,7 +71,7 @@ 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
|
||||
DOTGraphRenderer :: GraphRenderer ByteString
|
||||
|
||||
deriving instance Eq (GraphRenderer output)
|
||||
deriving instance Show (GraphRenderer output)
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
module Rendering.SExpression
|
||||
( renderSExpressionDiff
|
||||
, renderSExpressionTerm
|
||||
, renderSExpressionAST
|
||||
) where
|
||||
|
||||
import Prologue
|
||||
@ -9,6 +10,7 @@ import Data.ByteString.Char8
|
||||
import Data.Diff
|
||||
import Data.Patch
|
||||
import Data.Record
|
||||
import Data.AST
|
||||
import Data.Term
|
||||
import Prelude hiding (replicate)
|
||||
|
||||
@ -16,20 +18,28 @@ import Prelude hiding (replicate)
|
||||
renderSExpressionDiff :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Diff syntax (Record fields) (Record fields) -> ByteString
|
||||
renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n"
|
||||
|
||||
-- | Returns a ByteString SExpression formatted term.
|
||||
-- | Returns a ByteString SExpression formatted term (generalized).
|
||||
renderSExpressionTerm :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Term syntax (Record fields) -> ByteString
|
||||
renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n"
|
||||
renderSExpressionTerm = toSExpression showRecord
|
||||
|
||||
-- | Returns a ByteString SExpression formatted term (specialized)
|
||||
renderSExpressionAST :: Show grammar => Term [] (Node grammar) -> ByteString
|
||||
renderSExpressionAST = toSExpression (pack . show . nodeSymbol)
|
||||
|
||||
|
||||
toSExpression :: (Base t ~ TermF syntax ann, Foldable syntax, Recursive t) => (ann -> ByteString) -> t -> ByteString
|
||||
toSExpression showAnn term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF showAnn term n) term 0 <> "\n"
|
||||
|
||||
printDiffF :: (ConstrainAll Show fields, Foldable syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
|
||||
printDiffF diff n = case diff of
|
||||
Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
|
||||
Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}"
|
||||
Patch (Replace term1 term2) -> nl n <> pad (n - 1) <> "{ " <> printTermF term1 n
|
||||
<> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }"
|
||||
Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
|
||||
Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF showRecord term n <> "-}"
|
||||
Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF showRecord term n <> "+}"
|
||||
Patch (Replace term1 term2) -> nl n <> pad (n - 1) <> "{ " <> printTermF showRecord term1 n
|
||||
<> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF showRecord term2 n <> " }"
|
||||
Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showRecord ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
|
||||
|
||||
printTermF :: (ConstrainAll Show fields, Foldable syntax) => TermF syntax (Record fields) (Int -> ByteString) -> Int -> ByteString
|
||||
printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")"
|
||||
printTermF :: Foldable syntax => (ann -> ByteString) -> TermF syntax ann (Int -> ByteString) -> Int -> ByteString
|
||||
printTermF f (In ann syntax) n = "(" <> f ann <> foldMap (\t -> t (succ n)) syntax <> ")"
|
||||
|
||||
nl :: Int -> ByteString
|
||||
nl n | n <= 0 = ""
|
||||
@ -38,8 +48,7 @@ nl n | n <= 0 = ""
|
||||
pad :: Int -> ByteString
|
||||
pad n = replicate (2 * n) ' '
|
||||
|
||||
|
||||
showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString
|
||||
showAnnotation Nil = ""
|
||||
showAnnotation (only :. Nil) = pack (show only)
|
||||
showAnnotation (first :. rest) = pack (show first) <> " " <> showAnnotation rest
|
||||
showRecord :: ConstrainAll Show fields => Record fields -> ByteString
|
||||
showRecord Nil = ""
|
||||
showRecord (only :. Nil) = pack (show only)
|
||||
showRecord (first :. rest) = pack (show first) <> " " <> showRecord rest
|
||||
|
||||
@ -17,10 +17,10 @@ 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)
|
||||
import qualified Semantic.Parse as Semantic (parseBlobs, astParseBlobs)
|
||||
import qualified Semantic.Task as Task
|
||||
import System.IO (Handle, stdin, stdout)
|
||||
import Text.Read
|
||||
@ -34,8 +34,11 @@ 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
|
||||
runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
|
||||
runASTParse (SomeRenderer parseTreeRenderer) = Semantic.astParseBlobs parseTreeRenderer <=< Task.readBlobs
|
||||
|
||||
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,20 +59,20 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning
|
||||
|
||||
argumentsParser = do
|
||||
subparser <- hsubparser (diffCommand <> parseCommand <> graphCommand)
|
||||
subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand)
|
||||
output <- Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout)
|
||||
pure $ subparser >>= Task.writeToOutput output
|
||||
|
||||
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
|
||||
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
|
||||
diffArgumentsParser = do
|
||||
renderer <- flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
|
||||
renderer <- flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
|
||||
<|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
|
||||
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
|
||||
<|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph")
|
||||
filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
|
||||
pure $ runDiff renderer filesOrStdin
|
||||
|
||||
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)"))
|
||||
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
|
||||
parseArgumentsParser = do
|
||||
renderer <- flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
|
||||
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
|
||||
@ -84,15 +87,26 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||
pure $ runParse renderer filesOrStdin
|
||||
|
||||
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
|
||||
graphArgumentsParser = do
|
||||
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 <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
|
||||
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
|
||||
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
|
||||
tsParseArgumentsParser = do
|
||||
renderer <- flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression ASTs (default)")
|
||||
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON ASTs")
|
||||
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||
pure $ runASTParse renderer filesOrStdin
|
||||
|
||||
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 (default)")
|
||||
<|> 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 "DIR:LANGUAGE | FILE")
|
||||
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 "DIR"))
|
||||
excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
|
||||
filePathReader = eitherReader parseFilePath
|
||||
parseFilePath arg = case splitWhen (== ':') arg of
|
||||
[a, b] | lang <- readMaybe b -> Right (File a lang)
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
|
||||
{-# LANGUAGE GADTs, TypeOperators #-}
|
||||
module Semantic.Graph where
|
||||
|
||||
import Analysis.Abstract.Evaluating
|
||||
import Analysis.Abstract.ImportGraph
|
||||
import Analysis.Abstract.Graph
|
||||
import qualified Control.Exception as Exc
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable
|
||||
@ -14,30 +14,35 @@ import Data.ByteString.Char8 (pack)
|
||||
import Data.File
|
||||
import Data.Output
|
||||
import Data.Semilattice.Lower
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term
|
||||
import Parsing.Parser
|
||||
import Prologue hiding (MonadError (..))
|
||||
import Rendering.Renderer
|
||||
import Semantic.IO (Files)
|
||||
import Semantic.Task as 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 '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
|
||||
parsePackage parser prelude project >>= graphImports >>= case renderer of
|
||||
package <- parsePackage parser prelude project
|
||||
let graph package = case graphType of
|
||||
ImportGraph -> analyze runGraphAnalysis (evaluatePackageWith graphingModules graphingLoadErrors package) >>= extractGraph
|
||||
CallGraph -> analyze runGraphAnalysis (evaluatePackageWith graphingModules (graphingLoadErrors . graphingTerms) package) >>= extractGraph
|
||||
graph package >>= case renderer of
|
||||
JSONGraphRenderer -> pure . toOutput
|
||||
DOTGraphRenderer -> pure . renderImportGraph
|
||||
DOTGraphRenderer -> pure . renderGraph
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||
=> Parser term -- ^ A parser.
|
||||
-> Maybe File -- ^ Prelude (optional).
|
||||
-> Project -- ^ Project to parse into a package.
|
||||
=> Parser term -- ^ A parser.
|
||||
-> Maybe File -- ^ Prelude (optional).
|
||||
-> Project -- ^ Project to parse into a package.
|
||||
-> Eff effs (Package term)
|
||||
parsePackage parser preludeFile project@Project{..} = do
|
||||
prelude <- traverse (parseModule parser Nothing) preludeFile
|
||||
@ -57,31 +62,30 @@ parseModule parser rootDir file = do
|
||||
moduleForBlob rootDir blob <$> parse parser blob
|
||||
|
||||
|
||||
importGraphAnalysis :: forall term syntax ann a
|
||||
. Evaluator (Located Precise) term (Value (Located Precise))
|
||||
'[ State (ImportGraph (Term (Sum syntax) ann))
|
||||
, Resumable (AddressError (Located Precise) (Value (Located Precise)))
|
||||
, Resumable ResolutionError
|
||||
, Resumable (EvalError (Value (Located Precise)))
|
||||
, State [Name]
|
||||
, Resumable (ValueError (Located Precise) (Value (Located Precise)))
|
||||
, Resumable (Unspecialized (Value (Located Precise)))
|
||||
, Resumable (LoadError term)
|
||||
, Fail
|
||||
, Fresh
|
||||
, Reader (Environment (Located Precise) (Value (Located Precise)))
|
||||
, State (Environment (Located Precise) (Value (Located Precise)))
|
||||
, State (Heap (Located Precise) (Value (Located Precise)))
|
||||
, State (ModuleTable (Environment (Located Precise) (Value (Located Precise)), Value (Located Precise)))
|
||||
, State (Exports (Located Precise) (Value (Located Precise)))
|
||||
, State (JumpTable term)
|
||||
] a
|
||||
-> ( Either String -- 'fail' calls
|
||||
( ( a -- the result value
|
||||
, ImportGraph (Term (Sum syntax) ann)) -- the import graph
|
||||
, [Name]) -- the list of bad names
|
||||
, EvaluatingState (Located Precise) term (Value (Located Precise))) -- the final state
|
||||
importGraphAnalysis
|
||||
runGraphAnalysis :: Evaluator (Located Precise) term (Value (Located Precise))
|
||||
'[ State Graph
|
||||
, Resumable (AddressError (Located Precise) (Value (Located Precise)))
|
||||
, Resumable ResolutionError
|
||||
, Resumable (EvalError (Value (Located Precise)))
|
||||
, State [Name]
|
||||
, Resumable (ValueError (Located Precise) (Value (Located Precise)))
|
||||
, Resumable (Unspecialized (Value (Located Precise)))
|
||||
, Resumable (LoadError term)
|
||||
, Fail
|
||||
, Fresh
|
||||
, Reader (Environment (Located Precise) (Value (Located Precise)))
|
||||
, State (Environment (Located Precise) (Value (Located Precise)))
|
||||
, State (Heap (Located Precise) (Value (Located Precise)))
|
||||
, State (ModuleTable (Environment (Located Precise) (Value (Located Precise)), Value (Located Precise)))
|
||||
, State (Exports (Located Precise) (Value (Located Precise)))
|
||||
, State (JumpTable term)
|
||||
] a
|
||||
-> ( Either String -- 'fail' calls
|
||||
( ( a -- the result value
|
||||
, Graph) -- the import graph
|
||||
, [Name]) -- the list of bad names
|
||||
, EvaluatingState (Located Precise) term (Value (Located Precise))) -- the final state
|
||||
runGraphAnalysis
|
||||
= run
|
||||
. evaluating
|
||||
. resumingLoadError
|
||||
@ -90,7 +94,7 @@ importGraphAnalysis
|
||||
. resumingEvalError
|
||||
. resumingResolutionError
|
||||
. resumingAddressError
|
||||
. importGraphing
|
||||
. graphing
|
||||
|
||||
resumingResolutionError :: (Applicative (m effects), Effectful m) => m (Resumable ResolutionError ': effects) a -> m effects a
|
||||
resumingResolutionError = runResolutionErrorWith (\ err -> traceM ("ResolutionError:" <> show err) *> case err of
|
||||
@ -137,20 +141,7 @@ resumingValueError = runValueErrorWith (\ err -> traceM ("ValueError" <> show er
|
||||
KeyValueError{} -> pure (hole, hole)
|
||||
ArithmeticError{} -> pure hole)
|
||||
|
||||
-- | Render the import graph for a given 'Package'.
|
||||
graphImports :: ( Show ann
|
||||
, Apply Declarations1 syntax
|
||||
, Apply Evaluatable syntax
|
||||
, Apply FreeVariables1 syntax
|
||||
, Apply Functor syntax
|
||||
, Apply Show1 syntax
|
||||
, Element Syntax.Identifier syntax
|
||||
, Members '[Exc SomeException, Task] effs
|
||||
)
|
||||
=> Package (Term (Sum syntax) ann)
|
||||
-> Eff effs (ImportGraph (Term (Sum syntax) ann))
|
||||
graphImports package = analyze importGraphAnalysis (evaluatePackageWith graphingModules (graphingLoadErrors . graphingTerms) package) >>= extractGraph
|
||||
where
|
||||
extractGraph result = case result of
|
||||
(Right ((_, graph), _), _) -> pure graph
|
||||
_ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
|
||||
extractGraph :: (Member (Exc SomeException) effects, Show result, Show state) => (Either String ((result, Graph), [Name]), state) -> Eff effects Graph
|
||||
extractGraph result = case result of
|
||||
(Right ((_, graph), _), _) -> pure graph
|
||||
_ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
|
||||
|
||||
@ -11,6 +11,7 @@ module Semantic.IO
|
||||
, findFiles
|
||||
, languageForFilePath
|
||||
, NoLanguageForBlob(..)
|
||||
, FormatNotSupported(..)
|
||||
, readBlob
|
||||
, readProject
|
||||
, readBlobs
|
||||
@ -178,6 +179,10 @@ instance FromJSON BlobPair where
|
||||
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
|
||||
deriving (Eq, Exception, Ord, Show, Typeable)
|
||||
|
||||
-- | An exception indicating that the output format is not supported
|
||||
newtype FormatNotSupported = FormatNotSupported String
|
||||
deriving (Eq, Exception, Ord, Show, Typeable)
|
||||
|
||||
readBlob :: Member Files effs => File -> Eff effs Blob.Blob
|
||||
readBlob = send . ReadBlob
|
||||
|
||||
|
||||
@ -12,7 +12,7 @@ import Data.Record
|
||||
import Parsing.Parser
|
||||
import Prologue hiding (MonadError(..))
|
||||
import Rendering.Renderer
|
||||
import Semantic.IO (NoLanguageForBlob(..))
|
||||
import Semantic.IO (NoLanguageForBlob(..), FormatNotSupported(..))
|
||||
import Semantic.Task
|
||||
|
||||
parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
|
||||
@ -34,3 +34,20 @@ parseBlob renderer blob@Blob{..}
|
||||
SymbolsTermRenderer fields -> decorate (declarationAlgebra blob) >=> render (renderToSymbols fields blob)
|
||||
DOTTermRenderer -> render (renderDOTTerm blob)
|
||||
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
|
||||
|
||||
|
||||
astParseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
|
||||
astParseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . astParseBlob renderer) blobs
|
||||
where
|
||||
toOutput' = case renderer of
|
||||
JSONTermRenderer -> toOutput . renderJSONTerms
|
||||
_ -> toOutput
|
||||
|
||||
astParseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
|
||||
astParseBlob renderer blob@Blob{..}
|
||||
| Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
|
||||
= parse parser blob >>= case renderer of
|
||||
SExpressionTermRenderer -> render renderSExpressionAST
|
||||
JSONTermRenderer -> render (renderJSONTerm' blob)
|
||||
_ -> pure $ throwError (SomeException (FormatNotSupported "Only SExpression and JSON output supported for tree-sitter ASTs."))
|
||||
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user