diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 69fc940ff7..0f6dcac3f7 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -51,10 +51,10 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId)) { graphName = fromString (quote name) , vertexAttributes = vertexAttributes } where quote a = "\"" <> a <> "\"" - vertexAttributes (DiffTreeVertex _ (Just (Deleted (Just DeletedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "red" ] - vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "green" ] - vertexAttributes (DiffTreeVertex _ (Just (Replaced (Just ReplacedTerm{..})))) = [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ] - vertexAttributes (DiffTreeVertex _ (Just (Merged (Just MergedTerm{..})))) = [ "label" := fromString (T.unpack term) ] + vertexAttributes (DiffTreeVertex _ (Just (Deleted DeletedTerm{..}))) = [ "label" := fromString (T.unpack term), "color" := "red" ] + vertexAttributes (DiffTreeVertex _ (Just (Inserted InsertedTerm{..}))) = [ "label" := fromString (T.unpack term), "color" := "green" ] + vertexAttributes (DiffTreeVertex _ (Just (Replaced ReplacedTerm{..}))) = [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ] + vertexAttributes (DiffTreeVertex _ (Just (Merged MergedTerm{..}))) = [ "label" := fromString (T.unpack term) ] vertexAttributes _ = [] class ToTreeGraph vertex t | t -> vertex where @@ -82,16 +82,16 @@ instance (ConstructorName syntax, Foldable syntax) => instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) where toTreeGraph d = case d of - Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2)))) - Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1)))) - Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (InsertedTerm (T.pack (constructorName syntax)) (ann a2)))) + Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2))) + Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (DeletedTerm (T.pack (constructorName syntax)) (ann a1))) + Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (InsertedTerm (T.pack (constructorName syntax)) (ann a2))) Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do i <- fresh parent <- ask let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1) let (afterName, afterSpan) = (T.pack (constructorName syntax2), ann a2) - let replace = vertex (DiffTreeVertex (fromIntegral 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)))) + let replace = vertex (DiffTreeVertex (fromIntegral i) (Just (Replaced (ReplacedTerm beforeName beforeSpan afterName afterSpan)))) + graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (InsertedTerm afterName afterSpan)) pure (parent `connect` replace `overlay` graph) where ann a = converting #? locationSpan a diff --git a/src/Semantic/Api/V1/CodeAnalysisPB.hs b/src/Semantic/Api/V1/CodeAnalysisPB.hs index 6912350098..2be3d4ef9e 100644 --- a/src/Semantic/Api/V1/CodeAnalysisPB.hs +++ b/src/Semantic/Api/V1/CodeAnalysisPB.hs @@ -1,5 +1,5 @@ -- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT. -{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-} +{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-} module Semantic.Api.V1.CodeAnalysisPB where @@ -746,32 +746,46 @@ instance Proto3.Message DiffTreeEdge where <*> at decodeMessageField 2 dotProto = undefined -data DiffTreeVertexDiffTerm - = Deleted (Maybe DeletedTerm) - | Inserted (Maybe InsertedTerm) - | Replaced (Maybe ReplacedTerm) - | Merged (Maybe MergedTerm) - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (Proto3.Message, Proto3.Named, NFData) +data DiffTreeVertexDiffTerm = DiffTreeVertexDiffTerm + { deleted :: Maybe DeletedTerm + , inserted :: Maybe InsertedTerm + , replaced :: Maybe ReplacedTerm + , merged :: Maybe MergedTerm + } deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Proto3.Message, Proto3.Named, NFData) + +pattern Deleted :: DeletedTerm -> DiffTreeVertexDiffTerm +pattern Deleted a = DiffTreeVertexDiffTerm (Just a) Nothing Nothing Nothing + +pattern Inserted :: InsertedTerm -> DiffTreeVertexDiffTerm +pattern Inserted a = DiffTreeVertexDiffTerm Nothing (Just a) Nothing Nothing + +pattern Replaced :: ReplacedTerm -> DiffTreeVertexDiffTerm +pattern Replaced a = DiffTreeVertexDiffTerm Nothing Nothing (Just a) Nothing + +pattern Merged :: MergedTerm -> DiffTreeVertexDiffTerm +pattern Merged a = DiffTreeVertexDiffTerm Nothing Nothing Nothing (Just a) instance FromJSONPB DiffTreeVertexDiffTerm where - parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> msum - [ - Deleted <$> parseField obj "deleted" - , Inserted <$> parseField obj "inserted" - , Replaced <$> parseField obj "replaced" - , Merged <$> parseField obj "merged" - ] + parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> DiffTreeVertexDiffTerm + <$> obj .: "deleted" + <*> obj .: "inserted" + <*> obj .: "replaced" + <*> obj .: "merged" instance ToJSONPB DiffTreeVertexDiffTerm where - toJSONPB (Deleted x) = object [ "deleted" .= x ] - toJSONPB (Inserted x) = object [ "inserted" .= x ] - toJSONPB (Replaced x) = object [ "replaced" .= x ] - toJSONPB (Merged x) = object [ "merged" .= x ] - toEncodingPB (Deleted x) = pairs [ "deleted" .= x ] - toEncodingPB (Inserted x) = pairs [ "inserted" .= x ] - toEncodingPB (Replaced x) = pairs [ "replaced" .= x ] - toEncodingPB (Merged x) = pairs [ "merged" .= x ] + toJSONPB DiffTreeVertexDiffTerm{..} = object + [ "deleted" .= deleted + , "inserted" .= inserted + , "replaced" .= replaced + , "merged" .= merged + ] + toEncodingPB DiffTreeVertexDiffTerm{..} = pairs + [ "deleted" .= deleted + , "inserted" .= inserted + , "replaced" .= replaced + , "merged" .= merged + ] instance FromJSON DiffTreeVertexDiffTerm where parseJSON = parseJSONPB @@ -814,23 +828,11 @@ instance Proto3.Message DiffTreeVertex where encodeMessage _ DiffTreeVertex{..} = mconcat [ encodeMessageField 1 diffVertexId - , case diffTerm of - Nothing -> mempty - Just (Deleted deleted) -> encodeMessageField 2 deleted - Just (Inserted inserted) -> encodeMessageField 3 inserted - Just (Replaced replaced) -> encodeMessageField 4 replaced - Just (Merged merged) -> encodeMessageField 5 merged + , encodeMessageField 2 (Proto3.Nested diffTerm) ] decodeMessage _ = DiffTreeVertex <$> at decodeMessageField 1 - <*> oneof - Nothing - [ - (2, Just . Deleted <$> decodeMessageField) - , (3, Just . Inserted <$> decodeMessageField) - , (4, Just . Replaced <$> decodeMessageField) - , (5, Just . Merged <$> decodeMessageField) - ] + <*> at decodeMessageField 2 dotProto = undefined data DeletedTerm = DeletedTerm