Merge branch 'master' into scope-effects-to-evaluation

semantic.cabal

@@ -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

src/Analysis/Abstract/Graph.hs

@@ -1,15 +1,22 @@
 {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
-module Analysis.Abstract.ImportGraph
+module Analysis.Abstract.Graph
-( ImportGraph(..)
+( Graph(..)
-, renderImportGraph
+, 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) }
+newtype Graph = Graph { unGraph :: G.Graph Vertex }
-  deriving (Eq, Graph, Show)
+  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.
+-- | Render a 'Graph' to a 'ByteString' in DOT notation.
-renderImportGraph :: ImportGraph term -> ByteString
+renderGraph :: Graph -> ByteString
-renderImportGraph = export style . unImportGraph
+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
+packageInclusion :: ( Effectful m
-                             , State (ImportGraph term)
+                    , Members '[ Reader PackageInfo
-                             ] effects
+                               , State Graph
-                 => Vertex term
+                               ] effects
-                 -> Evaluator location term value 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
+moduleInclusion :: ( Effectful m
-                            , State (ImportGraph term)
+                   , Members '[ Reader ModuleInfo
-                            ] effects
+                              , State Graph
-                => Vertex term
+                              ] effects
-                -> Evaluator location term value 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
+instance Ord Graph where
-  compare (ImportGraph G.Empty)           (ImportGraph G.Empty)           = EQ
+  compare (Graph G.Empty)           (Graph G.Empty)           = EQ
-  compare (ImportGraph G.Empty)           _                               = LT
+  compare (Graph G.Empty)           _                               = LT
-  compare _                               (ImportGraph G.Empty)           = GT
+  compare _                               (Graph G.Empty)           = GT
-  compare (ImportGraph (G.Vertex a))      (ImportGraph (G.Vertex b))      = compare a b
+  compare (Graph (G.Vertex a))      (Graph (G.Vertex b))      = compare a b
-  compare (ImportGraph (G.Vertex _))      _                               = LT
+  compare (Graph (G.Vertex _))      _                               = LT
-  compare _                               (ImportGraph (G.Vertex _))      = GT
+  compare _                               (Graph (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 (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
-  compare (ImportGraph (G.Overlay _  _))  _                               = LT
+  compare (Graph (G.Overlay _  _))  _                               = LT
-  compare _                               (ImportGraph (G.Overlay _ _))   = GT
+  compare _                               (Graph (G.Overlay _ _))   = GT
-  compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
+  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
+instance ToJSON Graph where
-  toJSON ImportGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
+  toJSON Graph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
     where
-      vertices = toJSON (G.vertexList unImportGraph)
+      vertices = toJSON (G.vertexList unGraph)
-      edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unImportGraph)
+      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)
+graphing :: Effectful m => m (State Graph ': effects) result -> m effects (result, Graph)
-importGraphing = runState mempty
+graphing = runState mempty

src/Control/Abstract/Evaluator.hs

@@ -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
 
 

src/Data/AST.hs

@@ -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]
 

src/Parsing/Parser.hs

@@ -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

src/Rendering/JSON.hs

@@ -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

src/Rendering/Renderer.hs

@@ -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)

src/Rendering/SExpression.hs

@@ -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 (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF showRecord term n <> "-}"
-  Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}"
+  Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF showRecord term n <> "+}"
-  Patch (Replace term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> printTermF term1 n
+  Patch (Replace term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> printTermF showRecord term1 n
-                              <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }"
+                              <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF showRecord term2 n <> " }"
-  Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
+  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 :: Foldable syntax => (ann -> ByteString) -> TermF syntax ann (Int -> ByteString) -> Int -> ByteString
-printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")"
+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) ' '
 
-
+showRecord :: ConstrainAll Show fields => Record fields -> ByteString
-showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString
+showRecord Nil = ""
-showAnnotation Nil = ""
+showRecord (only :. Nil) = pack (show only)
-showAnnotation (only :. Nil) = pack (show only)
+showRecord (first :. rest) = pack (show first) <> " " <> showRecord rest
-showAnnotation (first :. rest) = pack (show first) <> " " <> showAnnotation rest

src/Semantic/CLI.hs

@@ -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
+runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
-runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs
+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"))
+    tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
-    graphArgumentsParser = do
+    tsParseArgumentsParser = do
-      renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
+      renderer <- flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression ASTs (default)")
-              <|> flag'                                (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
+              <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON ASTs")
-      rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
+      filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
-      excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
+      pure $ runASTParse renderer filesOrStdin
-      File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
-      pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
 
+    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)

src/Semantic/Graph.hs

@@ -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.
+             => Parser term -- ^ A parser.
-             -> Maybe File        -- ^ Prelude (optional).
+             -> Maybe File  -- ^ Prelude (optional).
-             -> Project           -- ^ Project to parse into a package.
+             -> 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
+runGraphAnalysis :: Evaluator (Located Precise) term (Value (Located Precise))
-                    .  Evaluator (Located Precise) term (Value (Located Precise))
+                      '[ State Graph
-                       '[ State (ImportGraph (Term (Sum syntax) ann))
+                       , Resumable (AddressError (Located Precise) (Value (Located Precise)))
-                        , Resumable (AddressError (Located Precise) (Value (Located Precise)))
+                       , Resumable ResolutionError
-                        , Resumable ResolutionError
+                       , Resumable (EvalError (Value (Located Precise)))
-                        , Resumable (EvalError (Value (Located Precise)))
+                       , State [Name]
-                        , State [Name]
+                       , Resumable (ValueError (Located Precise) (Value (Located Precise)))
-                        , Resumable (ValueError (Located Precise) (Value (Located Precise)))
+                       , Resumable (Unspecialized (Value (Located Precise)))
-                        , Resumable (Unspecialized (Value (Located Precise)))
+                       , Resumable (LoadError term)
-                        , Resumable (LoadError term)
+                       , Fail
-                        , Fail
+                       , Fresh
-                        , Fresh
+                       , Reader (Environment (Located Precise) (Value (Located Precise)))
-                        , Reader (Environment (Located Precise) (Value (Located Precise)))
+                       , State (Environment (Located Precise) (Value (Located Precise)))
-                        , State (Environment (Located Precise) (Value (Located Precise)))
+                       , State (Heap (Located Precise) (Value (Located Precise)))
-                        , State (Heap (Located Precise) (Value (Located Precise)))
+                       , State (ModuleTable (Environment (Located Precise) (Value (Located Precise)), Value (Located Precise)))
-                        , State (ModuleTable (Environment (Located Precise) (Value (Located Precise)), Value (Located Precise)))
+                       , State (Exports (Located Precise) (Value (Located Precise)))
-                        , State (Exports (Located Precise) (Value (Located Precise)))
+                       , State (JumpTable term)
-                        , State (JumpTable term)
+                       ] a
-                        ] a
+                 -> ( Either String                                                     -- 'fail' calls
-                    -> ( Either String                                                     -- 'fail' calls
+                      ( ( a                                                             -- the result value
-                         ( ( a                                                             -- the result value
+                        , Graph)                                                        -- the import graph
-                           , ImportGraph (Term (Sum syntax) ann))                          -- the import graph
+                      , [Name])                                                         -- the list of bad names
-                         , [Name])                                                         -- the list of bad names
+                    , EvaluatingState (Located Precise) term (Value (Located Precise))) -- the final state
-                       , EvaluatingState (Located Precise) term (Value (Located Precise))) -- the final state
+runGraphAnalysis
-importGraphAnalysis
   = 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'.
+extractGraph :: (Member (Exc SomeException) effects, Show result, Show state) => (Either String ((result, Graph), [Name]), state) -> Eff effects Graph
-graphImports :: ( Show ann
+extractGraph result = case result of
-                , Apply Declarations1 syntax
+  (Right ((_, graph), _), _) -> pure graph
-                , Apply Evaluatable syntax
+  _ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
-                , 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)))

src/Semantic/IO.hs

@@ -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
 

src/Semantic/Parse.hs

@@ -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))