From 2a2a1b9128386da1f09f52b71c62c6d4c660312b Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:29:14 -0700 Subject: [PATCH 1/4] Bring back dot rendering for terms and diffs The usage of local was problematic here. --- src/Rendering/Graph.hs | 40 +++++++++++++++++++-------------------- src/Rendering/Renderer.hs | 4 ++-- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 39feeda26..d0cbd791e 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE FunctionalDependencies, MonoLocalBinds #-} +{-# LANGUAGE FunctionalDependencies, MonoLocalBinds, ScopedTypeVariables #-} module Rendering.Graph ( renderTreeGraph , 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,51 +23,52 @@ 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 :: forall tag syntax ann effs. (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 | Merged | Replaced 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 diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index d211ea243..423db1aa2 100644 --- a/src/Rendering/Renderer.hs +++ b/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 From ca64ee2b074ca61508ec16c3a025ea20349a94e5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:30:19 -0700 Subject: [PATCH 2/4] Show replacements in the diff dot output --- src/Rendering/Graph.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index d0cbd791e..ceb598767 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -73,4 +73,9 @@ instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex 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) From f1d35283e73e239c59b18a30eccd1d6f59c60ba1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:31:15 -0700 Subject: [PATCH 3/4] No need for this, left over from debuggin --- src/Rendering/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index ceb598767..9d7a7ea49 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, MonoLocalBinds, ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies, MonoLocalBinds #-} module Rendering.Graph ( renderTreeGraph , termStyle @@ -27,7 +27,7 @@ runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex runGraph = run . runFresh 0 . runReader mempty -termAlgebra :: forall tag syntax ann effs. (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs) +termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs) => tag -> TermF syntax ann (Eff effs (Graph (TaggedVertex tag))) -> Eff effs (Graph (TaggedVertex tag)) From 30f7308f5fac92acd61c63152f6952ae8c45dacf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:32:23 -0700 Subject: [PATCH 4/4] This order is a little better --- src/Rendering/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 9d7a7ea49..294b3deca 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -58,7 +58,7 @@ diffStyle name = style name diffTagAttributes data TaggedVertex tag = TaggedVertex { vertexId :: Int, vertexTag :: tag, vertexName :: String } deriving (Eq, Ord, Show) -data DiffTag = Deleted | Inserted | Merged | Replaced +data DiffTag = Deleted | Inserted | Replaced | Merged deriving (Eq, Ord, Show)