diff graphs (adj list format) in the twirp api

src/Rendering/Graph.hs

@@ -13,13 +13,13 @@ import Control.Effect.Fresh
 import Control.Effect.Reader
 import Data.Diff
 import Data.Graph
-import Data.Graph.TermVertex
-import Data.Graph.DiffVertex
 import Data.Location
 import Data.Patch
-import Data.String (IsString(..))
+import Data.String (IsString (..))
 import Data.Term
 import Prologue
+import Semantic.API.Converters
+import Semantic.API.Types
 
 -- TODO: rename as this isn't a render
 renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
@@ -37,18 +37,19 @@ termStyle name = (defaultStyle (fromString . show . vertexId))
   { graphName = fromString (quote name)
   , vertexAttributes = vertexAttributes }
   where quote a = "\"" <> a <> "\""
-        vertexAttributes TermVertex{..} = ["label" := fromString vertexTermName]
+        vertexAttributes TermVertex{..} = ["label" := fromString name]
 
 -- | Graphviz styling for diffs
-diffStyle :: (IsString string, Monoid string) => String -> Style DiffVertex string
+diffStyle :: (IsString string, Monoid string) => String -> Style DiffTreeVertex 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 ]
+        vertexAttributes (DiffTreeVertex _ (Just (Deleted  (Just DeletedTerm{..}))))  = [ "label" := fromString deletedTermName,  "color" := "red" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString insertedTermName, "color" := "green" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Replaced (Just ReplacedTerm{..})))) = [ "label" := "Replacement",               "color" := "orange", "style" := "dashed" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Merged   (Just MergedTerm{..}))))   = [ "label" := fromString mergedTermName ]
+        vertexAttributes _ = []
 
 class ToTreeGraph vertex t | t -> vertex where
   toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex)
@@ -69,36 +70,36 @@ instance (ConstructorName syntax, Foldable syntax) =>
     termAlgebra (In ann syntax) = do
       i <- fresh
       parent <- ask
-      let root = vertex (TermVertex i (constructorName syntax) (TermAnnotation (locationByteRange ann) (locationSpan ann)))
+      let root = vertex (TermVertex i (constructorName syntax) (spanToSpan (locationSpan 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 DiffVertex (DiffF syntax Location Location) where
+  ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) 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)))
+    Merge t@(In (a1, a2) syntax)     -> diffAlgebra t  (Merged   (Just (MergedTerm (constructorName syntax) (ann a1) (ann a2))))
+    Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted  (Just (DeletedTerm (constructorName syntax) (ann a1))))
+    Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (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))
+      let (beforeName, beforeSpan) = (constructorName syntax1, ann a1)
+      let (afterName,  afterSpan) = (constructorName syntax2, ann a2)
+      let replace = vertex (DiffTreeVertex i (Just (Replaced (Just (ReplacedTerm beforeName beforeSpan afterName afterSpan)))))
+      graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
       pure (parent `connect` replace `overlay` graph)
     where
-      ann a = TermAnnotation (locationByteRange a) (locationSpan a)
+      ann a = spanToSpan (locationSpan a)
       diffAlgebra ::
         ( Foldable f
         , Member Fresh sig
-        , Member (Reader (Graph DiffVertex)) sig
+        , Member (Reader (Graph DiffTreeVertex)) sig
         , Carrier sig m
         , Monad m
-        ) => f (m (Graph DiffVertex)) -> DiffVertexTerm -> m (Graph DiffVertex)
+        ) => f (m (Graph DiffTreeVertex)) -> DiffTreeTerm -> m (Graph DiffTreeVertex)
       diffAlgebra syntax a = do
         i <- fresh
         parent <- ask
-        let root = vertex (DiffVertex i a)
+        let root = vertex (DiffTreeVertex i (Just a))
         subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
         pure (parent `connect` root `overlay` subGraph)

src/Semantic/API/Diffs.hs

@@ -2,6 +2,7 @@
 module Semantic.API.Diffs
   ( parseDiffBuilder
   , DiffOutputFormat(..)
+  , diffGraph
 
   , doDiff
   , DiffEffects
@@ -19,6 +20,7 @@ import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.ByteString.Builder
 import           Data.Diff
+import           Data.Graph
 import           Data.JSON.Fields
 import           Data.Language
 import           Data.Location
@@ -29,6 +31,7 @@ import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
+import           Semantic.API.Types
 import           Semantic.Task as Task
 import           Semantic.Telemetry as Stat
 import           Serializing.Format hiding (JSON)
@@ -49,6 +52,18 @@ parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
 parseDiffBuilder DiffShow        = distributeFoldMap showDiff
 parseDiffBuilder DiffDotGraph    = distributeFoldMap dotGraphDiff
 
+diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
+diffGraph = distributeFoldMap go
+  where
+    go :: (DiffEffects sig m) => BlobPair -> m DiffTreeGraphResponse
+    go blobPair = doDiff blobPair (const pure) render
+
+    render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeGraphResponse
+    render _ diff =
+      let graph = renderTreeGraph diff
+          toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
+      in pure $ DiffTreeGraphResponse (vertexList graph) (fmap toEdge (edgeList graph))
+
 type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Location Location -> m (Rendering.JSON.JSON "diffs" SomeJSON)
 
 jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)

src/Semantic/API/Types.hs

@@ -1,19 +1,35 @@
 {-# LANGUAGE DerivingVia, DerivingStrategies, DeriveAnyClass, DuplicateRecordFields #-}
 module Semantic.API.Types
   (
-  -- Symbols for jump-to-definition
+  -- Parse APIs
     ParseTreeRequest(..)
+
+  -- Symbols for jump-to-definition
   , ParseTreeSymbolResponse(..)
   , File(..)
   , Symbol(..)
 
-  -- TOC Summaries
+  -- Diff APIs
   , DiffTreeRequest(..)
+
+  -- TOC Summaries
   , DiffTreeTOCResponse(..)
   , TOCSummaryFile(..)
   , TOCSummaryChange(..)
   , TOCSummaryError(..)
 
+  -- Diff tree graphs
+  , DiffTreeGraphResponse(..)
+  , DiffTreeEdge(..)
+  , DiffTreeVertex(..)
+  , DiffTreeTerm(..)
+  , DeletedTerm(..)
+  , InsertedTerm(..)
+  , ReplacedTerm(..)
+  , MergedTerm(..)
+
+  , TermVertex(..)
+
   -- Health Check
   , PingRequest(..)
   , PingResponse(..)
@@ -29,9 +45,11 @@ module Semantic.API.Types
 import           Data.Aeson
 import           Data.Bifunctor (first)
 import           Data.ByteString.Lazy.Char8 as BC
+import           Data.Graph (VertexTag (..))
 import qualified Data.Text as T
 import           GHC.Generics
 import           Network.HTTP.Media ((//))
+import           Prologue
 import           Proto3.Suite as Proto3
 import           Servant.API
 
@@ -122,6 +140,64 @@ data TOCSummaryError = TOCSummaryError
   deriving stock (Eq, Show, Generic)
   deriving anyclass (Message, Named, ToJSON)
 
+--
+-- Diff Tree Graph API
+--
+
+data DiffTreeGraphResponse
+  = DiffTreeGraphResponse
+  { vertices :: [DiffTreeVertex]
+  , edges    :: [DiffTreeEdge]
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+  deriving Semigroup via GenericSemigroup DiffTreeGraphResponse
+  deriving Monoid via GenericMonoid DiffTreeGraphResponse
+
+
+data DiffTreeEdge = DiffTreeEdge { source :: Int, target :: Int }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
+data DiffTreeVertex = DiffTreeVertex { diffVertexId :: Int, term :: Maybe DiffTreeTerm }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+instance VertexTag DiffTreeVertex where uniqueTag = diffVertexId
+
+data TermVertex = TermVertex
+  { vertexId :: Int
+  , name :: String
+  , span :: Maybe Span
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+instance VertexTag TermVertex where uniqueTag = vertexId
+
+-- NB: Current proto generation only supports sum types with single named fields.
+data DiffTreeTerm
+  = Deleted  { deletedTerm   :: Maybe DeletedTerm }
+  | Inserted { insertedTerm  :: Maybe InsertedTerm }
+  | Replaced { replacedTerm  :: Maybe ReplacedTerm }
+  | Merged   { mergedTerm    :: Maybe MergedTerm }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
+data DeletedTerm = DeletedTerm { deletedTermName :: String, beforeSpan :: Maybe Span }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
+data InsertedTerm = InsertedTerm { insertedTermName :: String, afterSpan :: Maybe Span }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
+data ReplacedTerm = ReplacedTerm { beforeTermName :: String, beforeSpan :: Maybe Span, afterTermName :: String, afterSpan :: Maybe Span }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
+data MergedTerm = MergedTerm { mergedTermName :: String, beforeSpan :: Maybe Span, afterSpan :: Maybe Span }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Message, Named, ToJSON)
+
 
 --
 -- Health Check API
@@ -138,7 +214,7 @@ data PingResponse
   , timestamp :: String
   , sha :: String
   }
-  deriving stock (Eq, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
   deriving anyclass (Message, Named, ToJSON)
 
 instance MimeRender PlainText PingResponse where