Merge pull request #2119 from github/fix-dot-graphs

Fix term and diff dot graphs

src/Rendering/Graph.hs

@@ -4,7 +4,7 @@ module Rendering.Graph
 , termStyle
 , diffStyle
 , ToTreeGraph(..)
-, Vertex(..)
+, TaggedVertex(..)
 , DiffTag(..)
 ) where
 
@@ -16,7 +16,6 @@ import Control.Monad.Effect.Reader
 import Data.Diff
 import Data.Graph
 import Data.Patch
-import Data.Semigroup.App
 import Data.String (IsString(..))
 import Data.Term
 import Prologue
@@ -24,53 +23,59 @@ import Prologue
 renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
 renderTreeGraph = simplify . runGraph . cata toTreeGraph
 
-runGraph :: Eff '[Fresh, Reader (Graph vertex)] (Graph vertex) -> Graph vertex
-runGraph = run . runReader mempty . runFresh 0
+runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex
+runGraph = run . runFresh 0 . runReader mempty
 
 
-termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (Vertex tag))) effs)
+termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs)
             => tag
-            -> TermF syntax ann (Eff effs (Graph (Vertex tag)))
-            -> Eff effs (Graph (Vertex tag))
-termAlgebra tag (In _ syntax) = do
+            -> TermF syntax ann (Eff effs (Graph (TaggedVertex tag)))
+            -> Eff effs (Graph (TaggedVertex tag))
+termAlgebra t (In _ syntax) = do
   i <- fresh
-  let root = vertex (Vertex i tag (constructorName syntax))
   parent <- ask
-  (parent `connect` root <>) <$> local (const root) (runAppMerge (foldMap AppMerge syntax))
+  let root = vertex (TaggedVertex i t (constructorName syntax))
+  subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
+  pure (parent `connect` root `overlay` subGraph)
 
-
-style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (Vertex tag) string
+style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (TaggedVertex tag) string
 style name tagAttributes = (defaultStyle (fromString . show . vertexId))
   { graphName = fromString (quote name)
   , vertexAttributes = vertexAttributes }
   where quote a = "\"" <> a <> "\""
-        vertexAttributes Vertex{..} = "label" := fromString vertexName : tagAttributes vertexTag
+        vertexAttributes TaggedVertex{..} = "label" := fromString vertexName : tagAttributes vertexTag
 
-termStyle :: (IsString string, Monoid string) => String -> Style (Vertex ()) string
+termStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex ()) string
 termStyle name = style name (const [])
 
-diffStyle :: (IsString string, Monoid string) => String -> Style (Vertex DiffTag) string
+diffStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex DiffTag) string
 diffStyle name = style name diffTagAttributes
   where diffTagAttributes Deleted  = ["color" := "red"]
         diffTagAttributes Inserted = ["color" := "green"]
+        diffTagAttributes Replaced = ["color" := "orange", "style" := "dashed"]
         diffTagAttributes _        = []
 
-data Vertex tag = Vertex { vertexId :: Int, vertexTag :: tag, vertexName :: String }
+data TaggedVertex tag = TaggedVertex { vertexId :: Int, vertexTag :: tag, vertexName :: String }
   deriving (Eq, Ord, Show)
 
-data DiffTag = Deleted | Inserted | Merged
+data DiffTag = Deleted | Inserted | Replaced | Merged
   deriving (Eq, Ord, Show)
 
 
 class ToTreeGraph vertex t | t -> vertex where
   toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
 
-instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex ()) (TermF syntax ann) where
   toTreeGraph = termAlgebra ()
 
-instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex DiffTag) (DiffF syntax ann1 ann2) where
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex DiffTag) (DiffF syntax ann1 ann2) where
   toTreeGraph d = case d of
     Merge t               -> termAlgebra Merged t
     Patch (Delete  t1)    ->          termAlgebra Deleted t1
     Patch (Insert     t2) ->                                     termAlgebra Inserted t2
-    Patch (Replace t1 t2) -> (<>) <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2
+    Patch (Replace t1 t2) -> do
+      i <- fresh
+      parent <- ask
+      let replace = vertex (TaggedVertex i Replaced "Replacement")
+      graph <- local (const replace) (overlay <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2)
+      pure (parent `connect` replace `overlay` graph)

src/Rendering/Renderer.hs

@@ -34,7 +34,7 @@ data DiffRenderer output where
   -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
   SExpressionDiffRenderer :: DiffRenderer Builder
   -- | Render to a 'ByteString' formatted as a DOT description of the diff.
-  DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag))
+  DOTDiffRenderer :: DiffRenderer (Graph (TaggedVertex DiffTag))
   -- | Render to a 'ByteString' formatted using the 'Show' instance.
   ShowDiffRenderer :: DiffRenderer Builder
 
@@ -50,7 +50,7 @@ data TermRenderer output where
   -- | Render to a list of symbols.
   SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON)
   -- | Render to a 'ByteString' formatted as a DOT description of the term.
-  DOTTermRenderer :: TermRenderer (Graph (Vertex ()))
+  DOTTermRenderer :: TermRenderer (Graph (TaggedVertex ()))
   -- | Render to a 'ByteString' formatted using the 'Show' instance.
   ShowTermRenderer :: TermRenderer Builder