From b42a7432b350fb49ac7782e7f672d7cf7a2adb6e Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 5 Nov 2022 08:27:13 -0600 Subject: [PATCH] fix: offer related information only when supported (#905) Make sure the client supports them via the client capabilities Signed-off-by: Rudi Grinberg --- CHANGES.md | 7 +++ ocaml-lsp-server/src/diagnostics.ml | 42 +++++++++----- ocaml-lsp-server/src/diagnostics.mli | 3 +- ocaml-lsp-server/src/import.ml | 2 + ocaml-lsp-server/src/ocaml_lsp_server.ml | 54 +++++++++--------- ocaml-lsp-server/src/state.ml | 13 +++-- ocaml-lsp-server/src/state.mli | 8 ++- .../e2e/__tests__/textDocument-diagnostics.ts | 56 +------------------ 8 files changed, 83 insertions(+), 102 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 36d616230..e72ab4e8a 100644 --- a/CHANGES.md +++ b/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 diff --git a/ocaml-lsp-server/src/diagnostics.ml b/ocaml-lsp-server/src/diagnostics.ml index 9095e9ec3..7fc3c5d5c 100644 --- a/ocaml-lsp-server/src/diagnostics.ml +++ b/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 diff --git a/ocaml-lsp-server/src/diagnostics.mli b/ocaml-lsp-server/src/diagnostics.mli index 121bee5f5..5ea069dc2 100644 --- a/ocaml-lsp-server/src/diagnostics.mli +++ b/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 diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index 80eb584ba..14caa8cc9 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/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 diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index cefb1ac90..d09aaae35 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/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,7 +227,7 @@ let on_initialize server (ip : InitializeParams.t) = Dune.create workspaces ip.capabilities - state.diagnostics + diagnostics progress state.store ~log:(State.log_msg server) @@ -214,7 +235,7 @@ let on_initialize server (ip : InitializeParams.t) = 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,14 +914,14 @@ 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 } -> @@ -908,7 +929,7 @@ let on_notification server (notification : Client_notification.t) : 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 diff --git a/ocaml-lsp-server/src/state.ml b/ocaml-lsp-server/src/state.ml index ec74aaadf..e4baf6fdf 100644 --- a/ocaml-lsp-server/src/state.ml +++ b/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,7 +62,12 @@ 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 = @@ -71,6 +75,7 @@ let initialize t params workspaces dune = { params ; workspaces ; dune + ; diagnostics ; exp_client_caps = Client.Experimental_capabilities.of_opt_json params.capabilities.experimental diff --git a/ocaml-lsp-server/src/state.mli b/ocaml-lsp-server/src/state.mli index d101deea2..2231f3767 100644 --- a/ocaml-lsp-server/src/state.mli +++ b/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 diff --git a/ocaml-lsp-server/test/e2e/__tests__/textDocument-diagnostics.ts b/ocaml-lsp-server/test/e2e/__tests__/textDocument-diagnostics.ts index e68e81bf3..5afa1a997 100644 --- a/ocaml-lsp-server/test/e2e/__tests__/textDocument-diagnostics.ts +++ b/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", },