Merge master into 🔥-monolithic-syntax

semantic-diff.cabal

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

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)

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 = (<>)

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)

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

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