Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Fix DiffTreeVertexDiffTerm definition to be a valid protobuf object. #180

Merged
merged 2 commits into from
Jun 25, 2019
Merged

Fix DiffTreeVertexDiffTerm definition to be a valid protobuf object. #180

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
90fabfe
Fix DiffTreeVertexDiffTerm definition to be a valid protobuf object.
Jun 25, 2019
72ad90f
Merge branch 'master' into fix-bad-proto-type
robrix Jun 25, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 9 additions & 9 deletions src/Rendering/Graph.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
76 changes: 39 additions & 37 deletions src/Semantic/Api/V1/CodeAnalysisPB.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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 #-}
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does the above comment imply that our pattern synonyms will be overwritten?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, unfortunately (though we haven't regenerated this file in ages). I'm going to file a bug with the upstream proto3-suite to add generation of pattern synonyms for oneof types.

{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
module Semantic.Api.V1.CodeAnalysisPB where

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down