github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Support rendering raw tree-sitter ASTs

Browse Source
This commit is contained in:
Timothy Clem 2018-05-01 09:51:34 -07:00
parent 19157b0bcb
commit 91961a6bec
7 changed files with 60 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/Data/AST.hs
View File

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

5
src/Parsing/Parser.hs
View File

@ -151,8 +151,11 @@ 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 :: 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))

4
src/Rendering/JSON.hs
View File

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

1
src/Rendering/Renderer.hs
View File

@ -10,6 +10,7 @@ module Rendering.Renderer
, renderJSONDiff
, renderJSONDiffs
, renderJSONTerm
, renderJSONTerm'
, renderJSONTerms
, renderToCDiff
, renderToCTerm

35
src/Rendering/SExpression.hs
View File

@ -18,24 +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
renderSExpressionAST :: Show grammar => AST [] grammar -> ByteString
renderSExpressionAST term = pack (show term)
-- | 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 = ""
@ -44,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

14
src/Semantic/CLI.hs
View File

@ -20,7 +20,7 @@ import qualified Semantic.Diff as Semantic (diffBlobPairs)
import qualified Semantic.Graph as Semantic (graph)
import Semantic.IO (languageForFilePath)
import qualified Semantic.Log as Log
import qualified Semantic.Parse as Semantic (parseBlobs, 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,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
runTSParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
runTSParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs' parseTreeRenderer <=< Task.readBlobs
runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
runASTParse (SomeRenderer parseTreeRenderer) = Semantic.astParseBlobs 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
@ -87,12 +87,12 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ runParse renderer filesOrStdin
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter parse trees for path(s)"))
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 parse trees (default)")
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
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 $ runTSParse renderer filesOrStdin
pure $ runASTParse renderer filesOrStdin
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
graphArgumentsParser = do

26
src/Semantic/Parse.hs
View File

@ -36,16 +36,18 @@ parseBlob renderer blob@Blob{..}
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
parseBlobs' :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
parseBlobs' renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . parseBlob' renderer) blobs
where toOutput' = case renderer of
JSONTermRenderer -> toOutput . renderJSONTerms
_ -> toOutput
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
parseBlob' :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
parseBlob' renderer blob@Blob{..}
| Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
= parse parser blob >>= case renderer of
SExpressionTermRenderer -> render renderSExpressionAST
_ -> undefined --decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
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)
_ -> Prelude.fail "Only SExpression and JSON output supported for tree-sitter ASTs."
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))