diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 0a81a6f56..173360a8f 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -80,6 +80,7 @@ library , Parsing.TreeSitter , Paths_semantic_diff -- Rendering formats + , Rendering.DOT , Rendering.JSON , Rendering.Renderer , Rendering.SExpression diff --git a/src/Analysis/ConstructorName.hs b/src/Analysis/ConstructorName.hs index 07c936b71..a607cbf70 100644 --- a/src/Analysis/ConstructorName.hs +++ b/src/Analysis/ConstructorName.hs @@ -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) diff --git a/src/Rendering/DOT.hs b/src/Rendering/DOT.hs new file mode 100644 index 000000000..29df8fc5a --- /dev/null +++ b/src/Rendering/DOT.hs @@ -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 = (<>) diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index c9a557e83..6cceb394d 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -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 @@ -31,6 +34,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) @@ -45,6 +50,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) diff --git a/src/Semantic.hs b/src/Semantic.hs index f72f08291..3edaae179 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -53,7 +53,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) | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) data NoLanguageForBlob = NoLanguageForBlob FilePath @@ -71,7 +71,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 | otherwise = throwError (SomeException (NoLanguageForBlob effectivePath)) where effectivePath = pathForBlobPair blobs effectiveLanguage = languageForBlobPair blobs diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index beffd3349..b6e101e4e 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -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 ToCDiffRenderer) (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) )