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

Merge pull request #1453 from github/dot-renderer

Browse Source 
DOT renderer
This commit is contained in:
Rob Rix 2017-12-18 22:49:06 -07:00 committed by GitHub
commit 7f94a7ee7c
6 changed files with 91 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic-diff.cabal
View File

@ -83,6 +83,7 @@ library
, Parsing.TreeSitter
, Paths_semantic_diff
-- Rendering formats
, Rendering.DOT
, Rendering.JSON
, Rendering.Renderer
, Rendering.SExpression

2
src/Analysis/ConstructorName.hs
View File

@ -19,7 +19,7 @@ constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLab
constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s)
newtype ConstructorLabel = ConstructorLabel ByteString
newtype ConstructorLabel = ConstructorLabel { unConstructorLabel :: ByteString }
instance Show ConstructorLabel where
showsPrec _ (ConstructorLabel s) = showString (unpack s)

74
src/Rendering/DOT.hs Normal file
View File

@ -0,0 +1,74 @@
{-# LANGUAGE MonoLocalBinds #-}
module Rendering.DOT
( renderDOTDiff
, renderDOTTerm
) where
import Analysis.ConstructorName
import Control.Applicative
import Data.Bifunctor.Join (Join(..))
import Data.Blob
import qualified Data.ByteString.Char8 as B
import Data.Diff
import Data.Foldable
import Data.Functor.Foldable hiding (fold)
import qualified Data.Map as Map
import Data.Patch
import Data.Semigroup
import Data.Term
import Data.These (These, mergeThese)
renderDOTDiff :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Join These Blob -> Diff syntax ann1 ann2 -> B.ByteString
renderDOTDiff blobs diff = renderGraph (snd (cata diffAlgebra diff 0)) { graphName = Just (B.pack (mergeThese combine (runJoin (blobPath <$> blobs)))) }
where combine p1 p2 = p1 <> " -> " <> p2
renderDOTTerm :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Blob -> Term syntax ann -> B.ByteString
renderDOTTerm Blob{..} term = renderGraph (snd (cata termAlgebra term 0)) { graphName = Just (B.pack blobPath) }
diffAlgebra :: (ConstructorName syntax, Foldable syntax) => DiffF syntax ann1 ann2 (Int -> ([Int], Graph)) -> Int -> ([Int], Graph)
diffAlgebra d i = case d of
Merge t -> termAlgebra t i
Patch (Delete t1) -> termAlgebra t1 i `modifyHeadNode` setColour "red"
Patch (Insert t2) -> termAlgebra t2 i `modifyHeadNode` setColour "green"
Patch (Replace t1 t2) -> let r1 = termAlgebra t1 i `modifyHeadNode` setColour "red"
in r1 <> termAlgebra t2 (succ (maximum (i : map nodeID (graphNodes (snd r1))))) `modifyHeadNode` setColour "green"
where modifyHeadNode (i, g) f | n:ns <- graphNodes g = (i, g { graphNodes = f n : ns })
| otherwise = (i, g)
setColour c n = n { nodeAttributes = Map.insert "color" c (nodeAttributes n) }
termAlgebra :: (ConstructorName syntax, Foldable syntax) => TermF syntax ann (Int -> ([Int], Graph)) -> Int -> ([Int], Graph)
termAlgebra t i = ([succ i], Graph
Nothing
(Node (succ i) (Map.singleton "label" (unConstructorLabel (constructorLabel t))) : graphNodes g)
(concatMap (map (Edge (succ i))) is <> graphEdges g))
where (_, is, g) = foldr combine (succ i, [], mempty) (toList t)
combine f (i, is, gs) = let (i', g) = f i in (maximum (i : map nodeID (graphNodes g)), i' : is, g <> gs)
data Graph = Graph { graphName :: Maybe B.ByteString, graphNodes :: [Node], graphEdges :: [Edge] }
deriving (Eq, Ord, Show)
data Node = Node { nodeID :: Int, nodeAttributes :: Map.Map B.ByteString B.ByteString }
deriving (Eq, Ord, Show)
data Edge = Edge { edgeFrom :: Int, edgeTo :: Int }
deriving (Eq, Ord, Show)
renderGraph :: Graph -> B.ByteString
renderGraph Graph{..} = "digraph " <> maybe "" quote graphName <> " {\n" <> foldr ((<>) . renderNode) "" graphNodes <> foldr ((<>) . renderEdge) "" graphEdges <> "}"
where quote a = "\"" <> a <> "\""
renderNode :: Node -> B.ByteString
renderNode Node{..} = "\t" <> B.pack (show nodeID) <> " [ " <> foldr (\ (key, value) rest -> key <> " = \"" <> value <> "\" " <> rest) "" (Map.toList nodeAttributes) <> "];\n"
renderEdge :: Edge -> B.ByteString
renderEdge Edge{..} = "\t" <> B.pack (show edgeFrom) <> " -> " <> B.pack (show edgeTo) <> ";\n"
instance Semigroup Graph where
Graph n1 ns1 es1 <> Graph n2 ns2 es2 = Graph (n1 <|> n2) (ns1 <> ns2) (es1 <> es2)
instance Monoid Graph where
mempty = Graph Nothing [] []
mappend = (<>)

7
src/Rendering/Renderer.hs
View File

@ -10,6 +10,8 @@ module Rendering.Renderer
, renderToCDiff
, renderToCTerm
, renderToTags
, renderDOTDiff
, renderDOTTerm
, Summaries(..)
) where
@ -18,6 +20,7 @@ import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Output
import Data.Text (Text)
import Rendering.DOT as R
import Rendering.JSON as R
import Rendering.SExpression as R
import Rendering.Tag as R
@ -33,6 +36,8 @@ data DiffRenderer output where
JSONDiffRenderer :: DiffRenderer (Map.Map Text Value)
-- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
SExpressionDiffRenderer :: DiffRenderer ByteString
-- | Render to a 'ByteString' formatted as a DOT description of the diff.
DOTDiffRenderer :: DiffRenderer ByteString
deriving instance Eq (DiffRenderer output)
deriving instance Show (DiffRenderer output)
@ -47,6 +52,8 @@ data TermRenderer output where
SExpressionTermRenderer :: TermRenderer ByteString
-- | Render to a list of tags.
TagsTermRenderer :: TermRenderer [Value]
-- | Render to a 'ByteString' formatted as a DOT description of the term.
DOTTermRenderer :: TermRenderer ByteString
deriving instance Eq (TermRenderer output)
deriving instance Show (TermRenderer output)

4
src/Semantic.hs
View File

@ -56,6 +56,7 @@ parseBlob renderer blob@Blob{..}
JSONTermRenderer -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
DOTTermRenderer -> render (renderDOTTerm blob)
| Just parser <- blobLanguage >>= syntaxParserForLanguage
= parse parser blob >>= case renderer of
@ -63,6 +64,7 @@ parseBlob renderer blob@Blob{..}
JSONTermRenderer -> decorate syntaxIdentifierAlgebra >=> render (renderJSONTerm blob)
SExpressionTermRenderer -> render renderSExpressionTerm . fmap keepCategory
TagsTermRenderer -> decorate (syntaxDeclarationAlgebra blob) >=> render (renderToTags blob)
DOTTermRenderer -> render (renderDOTTerm blob)
| otherwise = throwError (SomeException (NoParserForLanguage blobPath blobLanguage))
@ -82,6 +84,7 @@ diffBlobPair renderer blobs
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms renderToCDiff
JSONDiffRenderer -> run ( parse parser >=> decorate constructorLabel >=> decorate identifierLabel) diffTerms renderJSONDiff
SExpressionDiffRenderer -> run ( parse parser >=> decorate constructorLabel . (Nil <$)) diffTerms (const renderSExpressionDiff)
DOTDiffRenderer -> run ( parse parser) diffTerms renderDOTDiff
| Just parser <- effectiveLanguage >>= syntaxParserForLanguage
= case renderer of
@ -89,6 +92,7 @@ diffBlobPair renderer blobs
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms renderToCDiff
JSONDiffRenderer -> run ( parse parser >=> decorate syntaxIdentifierAlgebra) diffSyntaxTerms renderJSONDiff
SExpressionDiffRenderer -> run ( parse parser >=> pure . fmap keepCategory) diffSyntaxTerms (const renderSExpressionDiff)
DOTDiffRenderer -> run ( parse parser) diffSyntaxTerms renderDOTDiff
| otherwise = throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage))
where effectiveLanguage = languageForBlobPair blobs

6
src/Semantic/CLI.hs
View File

@ -65,7 +65,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
<$> ( flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
<|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
<|> flag' (SomeRenderer OldToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc-assignment" <> help "Output JSON table of contents diff summary using the assignment parser") )
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc-assignment" <> help "Output JSON table of contents diff summary using the assignment parser")
<|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph"))
<*> ( Right <$> some (both
<$> argument filePathReader (metavar "FILE_A")
<*> argument filePathReader (metavar "FILE_B"))
@ -76,7 +77,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
<$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
<|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output JSON table of contents summary")
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols"))
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols")
<|> flag' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output the term as a DOT graph"))
<*> ( Right <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (Left stdin) )