mirror of
https://github.com/github/semantic.git
synced 2024-12-25 07:55:12 +03:00
Implement adj list diff tree JSON responses
Co-Authored-By: Rick Winfrey <rick.winfrey@gmail.com>
This commit is contained in:
Timothy Clem
parent
18c0554864
commit
e3f20f6903
@ -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{..}
|
||||
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{..}
|
||||
toEncoding TermVertex{..}
|
||||
= pairs ( fold ( "id" .= T.pack (show vertexId)
|
||||
: "name" .= vertexTermName
|
||||
: toJSONFields vertexRange ) )
|
||||
: 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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)")
|
||||
|
||||
@ -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"))
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user