From e3f20f6903ce6be29c6cef657e00ca698140612c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 5 Sep 2018 15:08:58 -0700 Subject: [PATCH] Implement adj list diff tree JSON responses Co-Authored-By: Rick Winfrey --- src/Rendering/Graph.hs | 214 +++++++++++++++++++++++++++----------- src/Rendering/JSON.hs | 18 +++- src/Rendering/Renderer.hs | 9 +- src/Semantic/CLI.hs | 1 + src/Semantic/Diff.hs | 5 + src/Semantic/Parse.hs | 4 +- 6 files changed, 182 insertions(+), 69 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index ec2b35354..9a78f9924 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -4,8 +4,8 @@ module Rendering.Graph , termStyle , diffStyle , ToTreeGraph(..) -, TaggedVertex(..) -, DiffTag(..) +, TermVertex(..) +, DiffVertex(..) ) where import Data.Aeson @@ -32,84 +32,176 @@ renderTreeGraph = simplify . runGraph . cata toTreeGraph runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex runGraph = run . runFresh 0 . runReader mempty - -termAlgebra :: - ( ConstructorName syntax - , HasField fields Range - , HasField fields Span - , Foldable syntax - , Member Fresh effs - , Member (Reader (Graph (TaggedVertex tag))) effs - ) - => tag - -> TermF syntax (Record fields) (Eff effs (Graph (TaggedVertex tag))) - -> Eff effs (Graph (TaggedVertex tag)) -termAlgebra t (In ann syntax) = do - i <- fresh - parent <- ask - let root = vertex (TaggedVertex i t (constructorName syntax) (getField ann) (getField ann)) - 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 (TaggedVertex tag) string -style name tagAttributes = (defaultStyle (fromString . show . vertexId)) +-- | GraphViz styling for terms +termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string +termStyle name = (defaultStyle (fromString . show . vertexId)) { graphName = fromString (quote name) , vertexAttributes = vertexAttributes } where quote a = "\"" <> a <> "\"" - vertexAttributes TaggedVertex{..} = "label" := fromString vertexTermName : tagAttributes vertexTag + vertexAttributes TermVertex{..} = ["label" := fromString vertexTermName] -termStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex ()) string -termStyle name = style name (const []) +-- | Graphviz styling for diffs +diffStyle :: (IsString string, Monoid string) => String -> Style DiffVertex string +diffStyle name = (defaultStyle (fromString . show . diffVertexId)) + { graphName = fromString (quote name) + , vertexAttributes = vertexAttributes } + where quote a = "\"" <> a <> "\"" + vertexAttributes (DiffVertex _ (Deleted DeletedTerm{..})) = [ "label" := fromString deletedTermName, "color" := "red" ] + vertexAttributes (DiffVertex _ (Inserted InsertedTerm{..})) = [ "label" := fromString insertedTermName, "color" := "green" ] + vertexAttributes (DiffVertex _ (Replaced ReplacedTerm{..})) = [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ] + vertexAttributes (DiffVertex _ (Merged MergedTerm{..})) = [ "label" := fromString mergedTermName ] -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 TaggedVertex tag - = TaggedVertex +data TermVertex + = TermVertex { vertexId :: Int - , vertexTag :: tag , vertexTermName :: String , vertexRange :: Range , vertexSpan :: Span } deriving (Eq, Ord, Show) -instance ToJSON (TaggedVertex ()) where - toJSON TaggedVertex{..} - = object $ [ "id" .= T.pack (show vertexId) - , "term" .= vertexTermName ] +data TermAnnotation + = TermAnnotation + { range :: Range + , span :: Span + } deriving (Eq, Ord, Show) + +instance ToJSON TermAnnotation where + toJSON TermAnnotation{..} = object $ toJSONFields range <> toJSONFields span + +instance ToJSONFields TermAnnotation where + toJSONFields TermAnnotation{..} = toJSONFields range <> toJSONFields span + +data MergedTerm + = MergedTerm + { mergedTermName :: String + , mergedTermBefore :: TermAnnotation + , mergedTermAfter :: TermAnnotation + } deriving (Eq, Ord, Show) + +instance ToJSON MergedTerm where + toJSON MergedTerm{..} = object [ "term" .= mergedTermName, "before" .= mergedTermBefore, "after" .= mergedTermAfter ] + +data DeletedTerm + = DeletedTerm + { deletedTermName :: String + , deletedTermBefore :: TermAnnotation + } deriving (Eq, Ord, Show) + +instance ToJSON DeletedTerm where + toJSON DeletedTerm{..} = object [ "term" .= deletedTermName, "before" .= deletedTermBefore ] + +data InsertedTerm + = InsertedTerm + { insertedTermName :: String + , insertedTermAfter :: TermAnnotation + } deriving (Eq, Ord, Show) + +instance ToJSON InsertedTerm where + toJSON InsertedTerm{..} = object [ "term" .= insertedTermName, "after" .= insertedTermAfter ] + +data ReplacedTerm + = ReplacedTerm + { replacedTermBefore :: DeletedTerm + , replacedTermAfter :: InsertedTerm + } deriving (Eq, Ord, Show) + +instance ToJSON ReplacedTerm where + toJSON (ReplacedTerm DeletedTerm{..} InsertedTerm{..}) + = object [ "before" .= deleted, "after" .= inserted ] + where deleted = object $ [ "term" .= deletedTermName ] <> toJSONFields deletedTermBefore + inserted = object $ [ "term" .= insertedTermName ] <> toJSONFields insertedTermAfter + +data DiffVertexTerm + = Deleted DeletedTerm + | Inserted InsertedTerm + | Replaced ReplacedTerm + | Merged MergedTerm + deriving (Eq, Ord, Show) + +data DiffVertex + = DiffVertex + { diffVertexId :: Int + , diffVertexTerm :: DiffVertexTerm + } deriving (Eq, Ord, Show) + +instance ToJSON TermVertex where + toJSON TermVertex{..} + = object $ [ "id" .= T.pack (show vertexId) + , "term" .= vertexTermName ] <> toJSONFields vertexRange <> toJSONFields vertexSpan - toEncoding TaggedVertex{..} - = pairs ( fold ( "id" .= T.pack (show vertexId) - : "name" .= vertexTermName - : toJSONFields vertexRange ) ) + toEncoding TermVertex{..} + = pairs ( fold ( "id" .= T.pack (show vertexId) + : "name" .= vertexTermName + : toJSONFields vertexRange + <> toJSONFields vertexSpan )) -instance JSONVertex (TaggedVertex ()) where + +instance JSONVertex TermVertex where jsonVertexId = T.pack . show . vertexId -data DiffTag = Deleted | Inserted | Replaced | Merged - deriving (Eq, Ord, Show) +instance ToJSON DiffVertex where + toJSON (DiffVertex i (Deleted t)) = object [ "id" .= T.pack (show i), "deleted" .= t ] + toJSON (DiffVertex i (Inserted t)) = object [ "id" .= T.pack (show i), "inserted" .= t ] + toJSON (DiffVertex i (Replaced t)) = object [ "id" .= T.pack (show i), "replaced" .= t ] + toJSON (DiffVertex i (Merged t)) = object [ "id" .= T.pack (show i), "merged" .= t ] + -- TODO + -- toEncoding = undefined + + +instance JSONVertex DiffVertex where + jsonVertexId = T.pack . show . diffVertexId 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, HasField fields Range, HasField fields Span) => ToTreeGraph (TaggedVertex ()) (TermF syntax (Record fields)) where - toTreeGraph = termAlgebra () +instance (ConstructorName syntax, Foldable syntax, HasField fields Range, HasField fields Span) => + ToTreeGraph TermVertex (TermF syntax (Record fields)) where + toTreeGraph = termAlgebra where + termAlgebra :: + ( ConstructorName syntax + , HasField fields Range + , HasField fields Span + , Foldable syntax + , Member Fresh effs + , Member (Reader (Graph TermVertex)) effs + ) + => TermF syntax (Record fields) (Eff effs (Graph TermVertex)) + -> Eff effs (Graph TermVertex) + termAlgebra (In ann syntax) = do + i <- fresh + parent <- ask + let root = vertex (TermVertex i (constructorName syntax) (getField ann) (getField ann)) + subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax + pure (parent `connect` root `overlay` subGraph) -instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex DiffTag) (DiffF syntax ann1 ann2) where - toTreeGraph = undefined - -- 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) -> 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) +instance (ConstructorName syntax, Foldable syntax, HasField fields1 Range, HasField fields1 Span, HasField fields2 Range, HasField fields2 Span) => + ToTreeGraph DiffVertex (DiffF syntax (Record fields1) (Record fields2)) where + toTreeGraph d = case d of + Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (MergedTerm (constructorName syntax) (ann a1) (ann a2))) + Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (DeletedTerm (constructorName syntax) (ann a1))) + Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (InsertedTerm (constructorName syntax) (ann a2))) + Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do + i <- fresh + parent <- ask + let a = DeletedTerm (constructorName syntax1) (ann a1) + let b = InsertedTerm (constructorName syntax2) (ann a2) + let replace = vertex (DiffVertex i (Replaced (ReplacedTerm a b))) + graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted a) <*> diffAlgebra t2 (Inserted b)) + pure (parent `connect` replace `overlay` graph) + where + ann a = TermAnnotation (getField a) (getField a) + diffAlgebra :: + ( Foldable f + , Member Fresh effs + , Member (Reader (Graph DiffVertex)) effs + ) => f (Eff effs (Graph DiffVertex)) -> DiffVertexTerm -> Eff effs (Graph DiffVertex) + diffAlgebra syntax a = do + i <- fresh + parent <- ask + let root = vertex (DiffVertex i a) + subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax + pure (parent `connect` root `overlay` subGraph) + + -- flatTerm (n, r, s) = FlatTerm n r s diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs index 60f753abd..2f59986c5 100644 --- a/src/Rendering/JSON.hs +++ b/src/Rendering/JSON.hs @@ -2,8 +2,9 @@ module Rendering.JSON ( JSON(..) , renderJSONDiff +, renderJSONAdjDiff , renderJSONTerm -, renderJSONAdjGraph +, renderJSONAdjTerm , renderJSONAST , renderSymbolTerms , renderJSONError @@ -38,6 +39,17 @@ instance ToJSON a => ToJSON (JSONDiff a) where toJSON JSONDiff{..} = object [ "diff" .= jsonDiff, "stat" .= jsonDiffStat ] toEncoding JSONDiff{..} = pairs ("diff" .= jsonDiff <> "stat" .= jsonDiffStat) +-- | Render a diff to a value representing its JSON. +renderJSONAdjDiff :: ToJSON a => BlobPair -> a -> JSON "diffs" SomeJSON +renderJSONAdjDiff blobs diff = JSON [ SomeJSON (JSONAdjDiff (JSONStat blobs) diff) ] + +data JSONAdjDiff a = JSONAdjDiff { jsonAdjDiffStat :: JSONStat, jsonAdjDiff :: a } + deriving (Eq, Show) + +instance ToJSON a => ToJSON (JSONAdjDiff a) where + toJSON JSONAdjDiff{..} = object [ "graph" .= jsonAdjDiff, "stat" .= jsonAdjDiffStat ] + toEncoding JSONAdjDiff{..} = pairs ("graph" .= jsonAdjDiff <> "stat" .= jsonAdjDiffStat) + newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair } deriving (Eq, Show) @@ -56,8 +68,8 @@ instance ToJSON a => ToJSON (JSONTerm a) where toJSON JSONTerm{..} = object ("tree" .= jsonTerm : toJSONFields jsonTermBlob) toEncoding JSONTerm{..} = pairs (fold ("tree" .= jsonTerm : toJSONFields jsonTermBlob)) -renderJSONAdjGraph :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON -renderJSONAdjGraph blob content = JSON [ SomeJSON (JSONAdjTerm blob content) ] +renderJSONAdjTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON +renderJSONAdjTerm blob content = JSON [ SomeJSON (JSONAdjTerm blob content) ] data JSONAdjTerm a = JSONAdjTerm { jsonAdjTermBlob :: Blob, jsonAdjTerm :: a } deriving (Eq, Show) diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index a50cfa216..fce9de643 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -3,8 +3,9 @@ module Rendering.Renderer ( DiffRenderer(..) , TermRenderer(..) , renderJSONDiff +, renderJSONAdjDiff , renderJSONTerm -, renderJSONAdjGraph +, renderJSONAdjTerm , renderJSONAST , renderToCDiff , renderRPCToCDiff @@ -33,10 +34,12 @@ data DiffRenderer output where ToCDiffRenderer :: DiffRenderer Summaries -- | Render to JSON with the format documented in docs/json-format.md JSONDiffRenderer :: DiffRenderer (JSON "diffs" SomeJSON) + -- | Render to JSON as an adjacency list. + JSONAdjDiffRenderer :: DiffRenderer (JSON "diffs" SomeJSON) -- | 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 (TaggedVertex DiffTag)) + DOTDiffRenderer :: DiffRenderer (Graph DiffVertex) -- | Render to a 'ByteString' formatted using the 'Show' instance. ShowDiffRenderer :: DiffRenderer Builder @@ -54,7 +57,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 (TaggedVertex ())) + DOTTermRenderer :: TermRenderer (Graph TermVertex) -- | Render to a 'ByteString' formatted using the 'Show' instance. ShowTermRenderer :: TermRenderer Builder diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 4967d3883..909d7f176 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -60,6 +60,7 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change diffArgumentsParser = do renderer <- flag (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)") <|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") + <|> flag' (Diff.runDiff JSONAdjDiffRenderer) (long "json-adj" <> help "Output JSON diff trees") <|> flag' (Diff.runDiff ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary") <|> flag' (Diff.runDiff DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph") <|> flag' (Diff.runDiff ShowDiffRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 7d9c7cb91..47382b4fe 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -25,6 +25,8 @@ import Semantic.IO (noLanguageForBlob) import Semantic.Telemetry as Stat import Semantic.Task as Task import Serializing.Format +import Rendering.JSON (SomeJSON (..)) +import qualified Rendering.JSON as JSON import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.Ruby.Assignment as Ruby import qualified Language.JSON.Assignment as JSON @@ -33,6 +35,9 @@ import qualified Language.Python.Assignment as Python runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON +runDiff JSONAdjDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON + where renderAdjGraph :: (Recursive t, ToTreeGraph DiffVertex (Base t)) => BlobPair -> t -> JSON.JSON "diffs" SomeJSON + renderAdjGraph blob diff = renderJSONAdjDiff blob (renderTreeGraph diff) runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName))) runDiff ShowDiffRenderer = withParsedBlobPairs (const pure) (const (serialize Show)) runDiff DOTDiffRenderer = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs")) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index e42e2427b..0d8f682df 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -34,8 +34,8 @@ import Serializing.Format runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder runParse JSONTermRenderer = withParsedBlobs renderJSONError (render . renderJSONTerm) >=> serialize JSON runParse JSONAdjTermRenderer = withParsedBlobs renderJSONError (render . renderAdjGraph) >=> serialize JSON - where renderAdjGraph :: (Recursive t, ToTreeGraph (TaggedVertex ()) (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON - renderAdjGraph blob term = renderJSONAdjGraph blob (renderTreeGraph term) + where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON + renderAdjGraph blob term = renderJSONAdjTerm blob (renderTreeGraph term) runParse SExpressionTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize (SExpression ByConstructorName))) runParse ShowTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize Show . quieterm)) runParse (SymbolsTermRenderer fields) = withParsedBlobs (\_ _ -> mempty) (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON