From 540f0eb76bb2a7244f82bc7b82b6decd070cf1bf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 25 Jul 2019 11:28:55 -0700 Subject: [PATCH] Revert manual oneof proto edits --- src/Rendering/Graph.hs | 18 ++++---- src/Semantic/Proto/SemanticPB.hs | 76 ++++++++++++++++---------------- 2 files changed, 46 insertions(+), 48 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 65f0ea1a4..dc9100ab1 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 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 (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 _ = [] 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 (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))) + 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)))) 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 (ReplacedTerm beforeName beforeSpan afterName afterSpan)))) - graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (InsertedTerm afterName afterSpan)) + 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)))) pure (parent `connect` replace `overlay` graph) where ann a = converting #? locationSpan a diff --git a/src/Semantic/Proto/SemanticPB.hs b/src/Semantic/Proto/SemanticPB.hs index a390f466a..0a5106edd 100644 --- a/src/Semantic/Proto/SemanticPB.hs +++ b/src/Semantic/Proto/SemanticPB.hs @@ -1,5 +1,5 @@ -- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT. -{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields, PatternSynonyms #-} +{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-} module Semantic.Proto.SemanticPB where @@ -746,46 +746,32 @@ instance Proto3.Message DiffTreeEdge where <*> at decodeMessageField 2 dotProto = undefined -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) +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) instance FromJSONPB DiffTreeVertexDiffTerm where - parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> DiffTreeVertexDiffTerm - <$> obj .: "deleted" - <*> obj .: "inserted" - <*> obj .: "replaced" - <*> obj .: "merged" + parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> msum + [ + Deleted <$> parseField obj "deleted" + , Inserted <$> parseField obj "inserted" + , Replaced <$> parseField obj "replaced" + , Merged <$> parseField obj "merged" + ] instance ToJSONPB DiffTreeVertexDiffTerm where - toJSONPB DiffTreeVertexDiffTerm{..} = object - [ "deleted" .= deleted - , "inserted" .= inserted - , "replaced" .= replaced - , "merged" .= merged - ] - toEncodingPB DiffTreeVertexDiffTerm{..} = pairs - [ "deleted" .= deleted - , "inserted" .= inserted - , "replaced" .= replaced - , "merged" .= merged - ] + 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 ] instance FromJSON DiffTreeVertexDiffTerm where parseJSON = parseJSONPB @@ -828,11 +814,23 @@ instance Proto3.Message DiffTreeVertex where encodeMessage _ DiffTreeVertex{..} = mconcat [ encodeMessageField 1 diffVertexId - , encodeMessageField 2 (Proto3.Nested diffTerm) + , 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 ] decodeMessage _ = DiffTreeVertex <$> at decodeMessageField 1 - <*> at decodeMessageField 2 + <*> oneof + Nothing + [ + (2, Just . Deleted <$> decodeMessageField) + , (3, Just . Inserted <$> decodeMessageField) + , (4, Just . Replaced <$> decodeMessageField) + , (5, Just . Merged <$> decodeMessageField) + ] dotProto = undefined data DeletedTerm = DeletedTerm