Skip to content

Commit

Permalink
Fix DiffTreeVertexDiffTerm definition to be a valid protobuf object.
Browse files Browse the repository at this point in the history 
We define the DiffTreeVertex protobuf message like so:

```protobuf
message DiffTreeVertex {
  int32 diff_vertex_id = 1;
  oneof diff_term {
    DeletedTerm deleted = 2;
    InsertedTerm inserted = 3;
    ReplacedTerm replaced = 4;
    MergedTerm merged = 5;
  }
}
```

This is turned into two Haskell types, a toplevel `DiffTreeVertex` type
and a `DiffTreeVertexDiffTerm` type that represents the anonymous
`oneof` type. Said types looked like so:

```haskell
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)
```

This is the wrong representation, as it neglects to account for the
fact that options could be added to the `diff_term` stanza. A sum type
does not provide enough constructors to handle the case of when none
of `deleted`, `inserted`, `replaced` etc. is `Just` anything. A more
correct definition follows:

```haskell
data DiffTreeVertexDiffTerm = DiffTreeVertexDiffTerm
  { deleted :: Maybe DeletedTerm
  , inserted :: Maybe InsertedTerm
  , replaced :: Maybe ReplacedTerm
  , merged :: Maybe MergedTerm
  }
```

This patch applies the above change, using `-XPatternSynonyms` to
provide backwards-compatible API shims. Though this changes JSON
output format (through the `ToJSON` instance), it should have no
bearing on backwards compatibility in protobuf objects, since there is
no way to consume diff trees as protobufs as of this writing.

Fixes #168.
  • Loading branch information
@patrickt
patrickt committed Jun 25, 2019
1 parent 9d1c024 commit 90fabfe
Show file tree
Hide file tree
Showing 2 changed files with 48 additions and 46 deletions.
18 changes: 9 additions & 9 deletions src/Rendering/Graph.hs
View file
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
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 #-}
{-# 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

0 comments on commit 90fabfe

Please sign in to comment.