From 63bd55a539c818ad34115a5e5ff21e3720dfea54 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Sat, 5 Nov 2022 00:38:50 -0600
Subject: [PATCH] fix(lsp): respect diagnostic tag client capabilities

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

ps-id: bcac66e6-7115-4eb2-99fa-a3ba09dabe37
---
 CHANGES.md                           |  2 ++
 ocaml-lsp-server/src/diagnostics.ml  | 40 +++++++++++++++++-----------
 ocaml-lsp-server/src/diagnostics.mli |  2 +-
 ocaml-lsp-server/src/dune.ml         | 10 ++++---
 4 files changed, 33 insertions(+), 21 deletions(-)

diff --git a/CHANGES.md b/CHANGES.md
index e72ab4e8a..5026a3554 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -5,6 +5,8 @@
 - Do not offer related diagnostic information unless the user enables in client
   capabilities (#905)
 
+- Do not offer diagnostic tags unless the client supports them (#909)
+
 # 1.14.1
 
 ## Fixes
diff --git a/ocaml-lsp-server/src/diagnostics.ml b/ocaml-lsp-server/src/diagnostics.ml
index a251b7d04..0506929bc 100644
--- a/ocaml-lsp-server/src/diagnostics.ml
+++ b/ocaml-lsp-server/src/diagnostics.ml
@@ -87,16 +87,21 @@ type t =
   ; send : PublishDiagnosticsParams.t list -> unit Fiber.t
   ; mutable dirty_uris : Uri_set.t
   ; related_information : bool
+  ; tags : DiagnosticTag.t list
   }
 
 let workspace_root t = Lazy.force t.workspace_root
 
 let create (capabilities : PublishDiagnosticsClientCapabilities.t option)
     ~workspace_root send =
-  let related_information =
+  let related_information, tags =
     match capabilities with
-    | None -> false
-    | Some c -> Option.value ~default:false c.relatedInformation
+    | None -> (false, [])
+    | Some c -> (
+      ( Option.value ~default:false c.relatedInformation
+      , match c.tagSupport with
+        | None -> []
+        | Some { valueSet } -> valueSet ))
   in
   { dune = Table.create (module Dune) 32
   ; merlin = Table.create (module Uri) 32
@@ -104,6 +109,7 @@ let create (capabilities : PublishDiagnosticsClientCapabilities.t option)
   ; send
   ; workspace_root
   ; related_information
+  ; tags
   }
 
 let send =
@@ -207,18 +213,20 @@ let disconnect t dune =
              t.dirty_uris <- Uri_set.add t.dirty_uris uri);
          Table.remove t.dune dune)
 
-(* this is not inlined in [tags_of_message] for reusability *)
-let diagnostic_tags_unnecessary = Some [ DiagnosticTag.Unnecessary ]
-
-let tags_of_message ~src message =
-  match src with
-  | `Dune when String.is_prefix message ~prefix:"unused" ->
-    diagnostic_tags_unnecessary
-  | `Merlin when Diagnostic_util.is_unused_var_warning message ->
-    diagnostic_tags_unnecessary
-  | `Merlin when Diagnostic_util.is_deprecated_warning message ->
-    Some [ DiagnosticTag.Deprecated ]
-  | `Dune | `Merlin -> None
+let tags_of_message =
+  let tags_of_message ~src message : DiagnosticTag.t option =
+    match src with
+    | `Dune when String.is_prefix message ~prefix:"unused" -> Some Unnecessary
+    | `Merlin when Diagnostic_util.is_unused_var_warning message ->
+      Some Unnecessary
+    | `Merlin when Diagnostic_util.is_deprecated_warning message ->
+      Some Deprecated
+    | `Dune | `Merlin -> None
+  in
+  fun t ~src message ->
+    match tags_of_message ~src message with
+    | None -> None
+    | Some tag -> Option.some_if (List.mem t.tags tag ~equal:Poly.equal) [ tag ]
 
 let extract_related_errors uri raw_message =
   match Ocamlc_loc.parse_raw raw_message with
@@ -320,7 +328,7 @@ let merlin_diagnostics diagnostics merlin =
                                  ~location
                                  ~message)) ))
                 in
-                let tags = tags_of_message ~src:`Merlin message in
+                let tags = tags_of_message diagnostics ~src:`Merlin message in
                 create_diagnostic
                   ?tags
                   ?relatedInformation
diff --git a/ocaml-lsp-server/src/diagnostics.mli b/ocaml-lsp-server/src/diagnostics.mli
index 5ea069dc2..411a09bb2 100644
--- a/ocaml-lsp-server/src/diagnostics.mli
+++ b/ocaml-lsp-server/src/diagnostics.mli
@@ -35,7 +35,7 @@ val remove :
 val disconnect : t -> Dune.t -> unit
 
 val tags_of_message :
-  src:[< `Dune | `Merlin ] -> string -> DiagnosticTag.t list option
+  t -> src:[< `Dune | `Merlin ] -> string -> DiagnosticTag.t list option
 
 val merlin_diagnostics : t -> Document.Merlin.t -> unit Fiber.t
 
diff --git a/ocaml-lsp-server/src/dune.ml b/ocaml-lsp-server/src/dune.ml
index 880518f18..dbbb3e824 100644
--- a/ocaml-lsp-server/src/dune.ml
+++ b/ocaml-lsp-server/src/dune.ml
@@ -171,7 +171,7 @@ end = struct
 
   let source t = t.source
 
-  let lsp_of_dune ~include_promotions diagnostic =
+  let lsp_of_dune diagnostics ~include_promotions diagnostic =
     let module D = Drpc.Diagnostic in
     let range_of_loc loc =
       let loc =
@@ -214,7 +214,7 @@ end = struct
                DiagnosticRelatedInformation.create ~location ~message))
     in
     let message = make_message (D.message diagnostic) in
-    let tags = Diagnostics.tags_of_message ~src:`Dune message in
+    let tags = Diagnostics.tags_of_message diagnostics ~src:`Dune message in
     let data =
       match include_promotions with
       | false -> None
@@ -343,8 +343,10 @@ end = struct
                   ( running.diagnostics_id
                   , id
                   , uri
-                  , lsp_of_dune ~include_promotions:config.include_promotions d
-                  ));
+                  , lsp_of_dune
+                      diagnostics
+                      ~include_promotions:config.include_promotions
+                      d ));
               (promotions, requests :: add, remove))
       in
       (promotions, List.flatten add, List.flatten remove)