Fix DiffTreeVertexDiffTerm definition to be a valid protobuf object.

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.

Author: Patrick Thomson

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

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