fix: offer related information only when supported (#905)

Make sure the client supports them via the client capabilities

Signed-off-by: Rudi Grinberg <[email protected]>

CHANGES.md

@@ -1,3 +1,10 @@
+# 1.14.2
+
+## Fixes
+
+- Do not offer related diagnostic information unless the user enables in client
+  capabilities (#905)
+
 # 1.14.1
 
 ## Fixes

ocaml-lsp-server/src/diagnostics.ml

@@ -86,16 +86,18 @@ type t =
   ; merlin : (Uri.t, Diagnostic.t list) Table.t
   ; send : PublishDiagnosticsParams.t list -> unit Fiber.t
   ; mutable dirty_uris : Uri_set.t
+  ; capabilities : PublishDiagnosticsClientCapabilities.t option
   }
 
 let workspace_root t = Lazy.force t.workspace_root
 
-let create send ~workspace_root =
+let create capabilities ~workspace_root send =
   { dune = Table.create (module Dune) 32
   ; merlin = Table.create (module Uri) 32
   ; dirty_uris = Uri_set.empty
   ; send
   ; workspace_root
+  ; capabilities
   }
 
 let send =
@@ -292,20 +294,30 @@ let merlin_diagnostics diagnostics merlin =
                 in
                 let message = make_message Loc.print_main error in
                 let message, relatedInformation =
-                  match error.sub with
-                  | [] -> extract_related_errors uri message
-                  | _ :: _ ->
-                    ( message
-                    , Some
-                        (List.map error.sub ~f:(fun (sub : Loc.msg) ->
-                             let location =
-                               let range = Range.of_loc sub.loc in
-                               Location.create ~range ~uri
-                             in
-                             let message = make_message Loc.print_sub_msg sub in
-                             DiagnosticRelatedInformation.create
-                               ~location
-                               ~message)) )
+                  let related_information =
+                    match diagnostics.capabilities with
+                    | None -> false
+                    | Some c -> Option.value ~default:false c.relatedInformation
+                  in
+                  match related_information with
+                  | false -> (message, None)
+                  | true -> (
+                    match error.sub with
+                    | [] -> extract_related_errors uri message
+                    | _ :: _ ->
+                      ( message
+                      , Some
+                          (List.map error.sub ~f:(fun (sub : Loc.msg) ->
+                               let location =
+                                 let range = Range.of_loc sub.loc in
+                                 Location.create ~range ~uri
+                               in
+                               let message =
+                                 make_message Loc.print_sub_msg sub
+                               in
+                               DiagnosticRelatedInformation.create
+                                 ~location
+                                 ~message)) ))
                 in
                 let tags = tags_of_message ~src:`Merlin message in
                 create_diagnostic

ocaml-lsp-server/src/diagnostics.mli

@@ -7,8 +7,9 @@ val dune_source : string
 type t
 
 val create :
-     (PublishDiagnosticsParams.t list -> unit Fiber.t)
+     PublishDiagnosticsClientCapabilities.t option
   -> workspace_root:Uri.t Lazy.t
+  -> (PublishDiagnosticsParams.t list -> unit Fiber.t)
   -> t
 
 val send : t -> [ `All | `One of Uri.t ] -> unit Fiber.t

ocaml-lsp-server/src/import.ml

@@ -236,6 +236,8 @@ include struct
   module ProgressParams = ProgressParams
   module ProgressToken = ProgressToken
   module PublishDiagnosticsParams = PublishDiagnosticsParams
+  module PublishDiagnosticsClientCapabilities =
+    PublishDiagnosticsClientCapabilities
   module ReferenceParams = ReferenceParams
   module Registration = Registration
   module RegistrationParams = RegistrationParams

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -191,6 +191,27 @@ let set_diagnostics detached diagnostics doc =
 let on_initialize server (ip : InitializeParams.t) =
   let state : State.t = Server.state server in
   let workspaces = Workspaces.create ip in
+  let diagnostics =
+    let workspace_root =
+      lazy
+        (let state = Server.state server in
+         State.workspace_root state)
+    in
+    Diagnostics.create
+      (let open Option.O in
+      let* td = ip.capabilities.textDocument in
+      td.publishDiagnostics)
+      ~workspace_root
+      (function
+        | [] -> Fiber.return ()
+        | diagnostics ->
+          let state = Server.state server in
+          task_if_running state.detached ~f:(fun () ->
+              let batch = Server.Batch.create server in
+              List.iter diagnostics ~f:(fun d ->
+                  Server.Batch.notification batch (PublishDiagnostics d));
+              Server.Batch.submit batch))
+  in
   let+ dune =
     let progress =
       Progress.create
@@ -206,15 +227,15 @@ let on_initialize server (ip : InitializeParams.t) =
       Dune.create
         workspaces
         ip.capabilities
-        state.diagnostics
+        diagnostics
         progress
         state.store
         ~log:(State.log_msg server)
     in
     let+ () = Fiber.Pool.task state.detached ~f:(fun () -> Dune.run dune) in
     dune
   in
-  let state = State.initialize state ip workspaces dune in
+  let state = State.initialize state ip workspaces dune diagnostics in
   let state =
     match ip.trace with
     | None -> state
@@ -893,22 +914,22 @@ let on_notification server (notification : Client_notification.t) :
     in
     assert (Document_store.get_opt store params.textDocument.uri = None);
     let* () = Document_store.open_document store doc in
-    let+ () = set_diagnostics state.detached state.diagnostics doc in
+    let+ () = set_diagnostics state.detached (State.diagnostics state) doc in
     state
   | TextDocumentDidClose { textDocument = { uri } } ->
     let+ () =
-      Diagnostics.remove state.diagnostics (`Merlin uri);
+      Diagnostics.remove (State.diagnostics state) (`Merlin uri);
       let* () = Document_store.close_document store uri in
       task_if_running state.detached ~f:(fun () ->
-          Diagnostics.send state.diagnostics (`One uri))
+          Diagnostics.send (State.diagnostics state) (`One uri))
     in
     state
   | TextDocumentDidChange { textDocument = { uri; version }; contentChanges } ->
     let doc =
       Document_store.change_document store uri ~f:(fun prev_doc ->
           Document.update_text ~version prev_doc contentChanges)
     in
-    let+ () = set_diagnostics state.detached state.diagnostics doc in
+    let+ () = set_diagnostics state.detached (State.diagnostics state) doc in
     state
   | CancelRequest _ ->
     Log.log ~section:"debug" (fun () -> Log.msg "ignoring cancellation" []);
@@ -932,7 +953,7 @@ let on_notification server (notification : Client_notification.t) :
                pipeline; otherwise the diagnostics don't get updated *)
             Document.update_text doc [])
       in
-      let+ () = set_diagnostics state.detached state.diagnostics doc in
+      let+ () = set_diagnostics state.detached (State.diagnostics state) doc in
       state)
   | ChangeWorkspaceFolders change ->
     let state =
@@ -973,24 +994,6 @@ let start () =
     let+ stdout = Lev_fiber.Io.stdout in
     Lsp_fiber.Fiber_io.make stdin stdout
   in
-  let diagnostics =
-    let workspace_root =
-      lazy
-        (let server = Fdecl.get server in
-         let state = Server.state server in
-         State.workspace_root state)
-    in
-    Diagnostics.create ~workspace_root (function
-        | [] -> Fiber.return ()
-        | diagnostics ->
-          let server = Fdecl.get server in
-          let state = Server.state server in
-          task_if_running state.detached ~f:(fun () ->
-              let batch = Server.Batch.create server in
-              List.iter diagnostics ~f:(fun d ->
-                  Server.Batch.notification batch (PublishDiagnostics d));
-              Server.Batch.submit batch))
-  in
   let ocamlformat_rpc = Ocamlformat_rpc.create () in
   let* configuration = Configuration.default () in
   let wheel = Configuration.wheel configuration in
@@ -1008,7 +1011,6 @@ let start () =
             ~ocamlformat_rpc
             ~configuration
             ~detached
-            ~diagnostics
             ~symbols_thread
             ~wheel));
     Fdecl.get server

ocaml-lsp-server/src/state.ml

@@ -7,6 +7,7 @@ type init =
       ; workspaces : Workspaces.t
       ; dune : Dune.t
       ; exp_client_caps : Client.Experimental_capabilities.t
+      ; diagnostics : Diagnostics.t
       }
 
 type t =
@@ -18,12 +19,11 @@ type t =
   ; configuration : Configuration.t
   ; trace : TraceValue.t
   ; ocamlformat_rpc : Ocamlformat_rpc.t
-  ; diagnostics : Diagnostics.t
   ; symbols_thread : Lev_fiber.Thread.t Lazy_fiber.t
   ; wheel : Lev_fiber.Timer.Wheel.t
   }
 
-let create ~store ~merlin ~detached ~configuration ~ocamlformat_rpc ~diagnostics
+let create ~store ~merlin ~detached ~configuration ~ocamlformat_rpc
     ~symbols_thread ~wheel =
   { init = Uninitialized
   ; merlin_config = Merlin_config.DB.create ()
@@ -33,7 +33,6 @@ let create ~store ~merlin ~detached ~configuration ~ocamlformat_rpc ~diagnostics
   ; configuration
   ; trace = Off
   ; ocamlformat_rpc
-  ; diagnostics
   ; symbols_thread
   ; wheel
   }
@@ -63,14 +62,20 @@ let dune t =
   | Uninitialized -> assert false
   | Initialized init -> init.dune
 
-let initialize t params workspaces dune =
+let diagnostics t =
+  match t.init with
+  | Uninitialized -> assert false
+  | Initialized init -> init.diagnostics
+
+let initialize t (params : InitializeParams.t) workspaces dune diagnostics =
   assert (t.init = Uninitialized);
   { t with
     init =
       Initialized
         { params
         ; workspaces
         ; dune
+        ; diagnostics
         ; exp_client_caps =
             Client.Experimental_capabilities.of_opt_json
               params.capabilities.experimental

ocaml-lsp-server/src/state.mli

@@ -7,6 +7,7 @@ type init =
       ; workspaces : Workspaces.t
       ; dune : Dune.t
       ; exp_client_caps : Client.Experimental_capabilities.t
+      ; diagnostics : Diagnostics.t
       }
 
 type t =
@@ -18,7 +19,6 @@ type t =
   ; configuration : Configuration.t
   ; trace : TraceValue.t
   ; ocamlformat_rpc : Ocamlformat_rpc.t
-  ; diagnostics : Diagnostics.t
   ; symbols_thread : Lev_fiber.Thread.t Lazy_fiber.t
   ; wheel : Lev_fiber.Timer.Wheel.t
   }
@@ -29,7 +29,6 @@ val create :
   -> detached:Fiber.Pool.t
   -> configuration:Configuration.t
   -> ocamlformat_rpc:Ocamlformat_rpc.t
-  -> diagnostics:Diagnostics.t
   -> symbols_thread:Lev_fiber.Thread.t Lazy_fiber.t
   -> wheel:Lev_fiber.Timer.Wheel.t
   -> t
@@ -38,7 +37,8 @@ val wheel : t -> Lev_fiber.Timer.Wheel.t
 
 val initialize_params : t -> InitializeParams.t
 
-val initialize : t -> InitializeParams.t -> Workspaces.t -> Dune.t -> t
+val initialize :
+  t -> InitializeParams.t -> Workspaces.t -> Dune.t -> Diagnostics.t -> t
 
 val workspace_root : t -> Uri.t
 
@@ -57,5 +57,7 @@ val client_capabilities : t -> ClientCapabilities.t
 (** @return experimental client capabilities *)
 val experimental_client_capabilities : t -> Client.Experimental_capabilities.t
 
+val diagnostics : t -> Diagnostics.t
+
 val log_msg :
   t Server.t -> type_:MessageType.t -> message:string -> unit Fiber.t

ocaml-lsp-server/test/e2e/__tests__/textDocument-diagnostics.ts

@@ -50,24 +50,6 @@ describe("textDocument/diagnostics", () => {
                     "line": 0,
                   },
                 },
-                "relatedInformation": Array [
-                  Object {
-                    "location": Object {
-                      "range": Object {
-                        "end": Object {
-                          "character": 4,
-                          "line": 0,
-                        },
-                        "start": Object {
-                          "character": 3,
-                          "line": 0,
-                        },
-                      },
-                      "uri": "file:///test.ml",
-                    },
-                    "message": "String literal begins here",
-                  },
-                ],
                 "severity": 1,
                 "source": "ocamllsp",
               },
@@ -183,7 +165,9 @@ describe("textDocument/diagnostics", () => {
           is not included in
             sig val x : unit end
           Values do not match: val x : int is not included in val x : unit
-          The type int is not compatible with the type unit",
+          The type int is not compatible with the type unit
+          File \\"test.ml\\", line 2, characters 2-14: Expected declaration
+          File \\"test.ml\\", line 4, characters 6-7: Actual declaration",
                 "range": Object {
                   "end": Object {
                     "character": 3,
@@ -194,40 +178,6 @@ describe("textDocument/diagnostics", () => {
                     "line": 2,
                   },
                 },
-                "relatedInformation": Array [
-                  Object {
-                    "location": Object {
-                      "range": Object {
-                        "end": Object {
-                          "character": 14,
-                          "line": 2,
-                        },
-                        "start": Object {
-                          "character": 2,
-                          "line": 2,
-                        },
-                      },
-                      "uri": "file:///test.ml",
-                    },
-                    "message": "Expected declaration",
-                  },
-                  Object {
-                    "location": Object {
-                      "range": Object {
-                        "end": Object {
-                          "character": 7,
-                          "line": 4,
-                        },
-                        "start": Object {
-                          "character": 6,
-                          "line": 4,
-                        },
-                      },
-                      "uri": "file:///test.ml",
-                    },
-                    "message": "Actual declaration",
-                  },
-                ],
                 "severity": 1,
                 "source": "ocamllsp",
               },