From cb06208ce9f2bf7c9714e2a1c74eb5d2c93bdf51 Mon Sep 17 00:00:00 2001 From: Eduardo Rafael Date: Fri, 5 Jan 2024 17:45:38 -0300 Subject: [PATCH] Add flag to disable dune diagnostics (#1221) * add config to control dune diagnostics --- CHANGES.md | 8 ++ ocaml-lsp-server/docs/ocamllsp/config.md | 7 ++ ocaml-lsp-server/src/config_data.ml | 111 ++++++++++++++++++++++- ocaml-lsp-server/src/configuration.ml | 5 + ocaml-lsp-server/src/configuration.mli | 2 + ocaml-lsp-server/src/diagnostics.ml | 27 ++++-- ocaml-lsp-server/src/diagnostics.mli | 4 + ocaml-lsp-server/src/ocaml_lsp_server.ml | 14 ++- 8 files changed, 168 insertions(+), 10 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 1aa10a76e..bed03fee7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +# Unreleased + +## Features + +- Introduce a configuration option to control dune diagnostics. The option is + called `duneDiganostics` and it may be set to `{ enable: false }` to disable + diagnostics. (#1221) + # 1.17.0 ## Fixes diff --git a/ocaml-lsp-server/docs/ocamllsp/config.md b/ocaml-lsp-server/docs/ocamllsp/config.md index ff2fa128c..1fa4398a1 100644 --- a/ocaml-lsp-server/docs/ocamllsp/config.md +++ b/ocaml-lsp-server/docs/ocamllsp/config.md @@ -21,5 +21,12 @@ interface config { * @since 1.16 */ codelens: { enable : boolean } + + /** + * Enable/Disable Dune diagnostics + * @default true + * @since 1.18 + */ + duneDiagnostics: { enable : boolean } } ``` diff --git a/ocaml-lsp-server/src/config_data.ml b/ocaml-lsp-server/src/config_data.ml index 8c2359203..000e63985 100644 --- a/ocaml-lsp-server/src/config_data.ml +++ b/ocaml-lsp-server/src/config_data.ml @@ -145,11 +145,85 @@ module ExtendedHover = struct [@@@end] end +module DuneDiagnostics = struct + type t = { enable : bool [@default true] } + [@@deriving_inline yojson] [@@yojson.allow_extra_fields] + + let _ = fun (_ : t) -> () + + let t_of_yojson = + (let _tp_loc = "ocaml-lsp-server/src/config_data.ml.DuneDiagnostics.t" in + function + | `Assoc field_yojsons as yojson -> ( + let enable_field = ref Ppx_yojson_conv_lib.Option.None + and duplicates = ref [] + and extra = ref [] in + let rec iter = function + | (field_name, _field_yojson) :: tail -> + (match field_name with + | "enable" -> ( + match Ppx_yojson_conv_lib.( ! ) enable_field with + | Ppx_yojson_conv_lib.Option.None -> + let fvalue = bool_of_yojson _field_yojson in + enable_field := Ppx_yojson_conv_lib.Option.Some fvalue + | Ppx_yojson_conv_lib.Option.Some _ -> + duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates) + | _ -> ()); + iter tail + | [] -> () + in + iter field_yojsons; + match Ppx_yojson_conv_lib.( ! ) duplicates with + | _ :: _ -> + Ppx_yojson_conv_lib.Yojson_conv_error.record_duplicate_fields + _tp_loc + (Ppx_yojson_conv_lib.( ! ) duplicates) + yojson + | [] -> ( + match Ppx_yojson_conv_lib.( ! ) extra with + | _ :: _ -> + Ppx_yojson_conv_lib.Yojson_conv_error.record_extra_fields + _tp_loc + (Ppx_yojson_conv_lib.( ! ) extra) + yojson + | [] -> + let enable_value = Ppx_yojson_conv_lib.( ! ) enable_field in + { enable = + (match enable_value with + | Ppx_yojson_conv_lib.Option.None -> true + | Ppx_yojson_conv_lib.Option.Some v -> v) + })) + | _ as yojson -> + Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom + _tp_loc + yojson + : Ppx_yojson_conv_lib.Yojson.Safe.t -> t) + + let _ = t_of_yojson + + let yojson_of_t = + (function + | { enable = v_enable } -> + let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in + let bnds = + let arg = yojson_of_bool v_enable in + ("enable", arg) :: bnds + in + `Assoc bnds + : t -> Ppx_yojson_conv_lib.Yojson.Safe.t) + + let _ = yojson_of_t + + [@@@end] +end + type t = { codelens : Lens.t Json.Nullable_option.t [@default None] [@yojson_drop_default ( = )] ; extended_hover : ExtendedHover.t Json.Nullable_option.t [@key "extendedHover"] [@default None] [@yojson_drop_default ( = )] + ; dune_diagnostics : DuneDiagnostics.t Json.Nullable_option.t + [@key "duneDiagnostics"] [@default None] [@yojson_drop_default ( = )] } [@@deriving_inline yojson] [@@yojson.allow_extra_fields] @@ -161,6 +235,7 @@ let t_of_yojson = | `Assoc field_yojsons as yojson -> ( let codelens_field = ref Ppx_yojson_conv_lib.Option.None and extended_hover_field = ref Ppx_yojson_conv_lib.Option.None + and dune_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None and duplicates = ref [] and extra = ref [] in let rec iter = function @@ -186,6 +261,17 @@ let t_of_yojson = extended_hover_field := Ppx_yojson_conv_lib.Option.Some fvalue | Ppx_yojson_conv_lib.Option.Some _ -> duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates) + | "duneDiagnostics" -> ( + match Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field with + | Ppx_yojson_conv_lib.Option.None -> + let fvalue = + Json.Nullable_option.t_of_yojson + DuneDiagnostics.t_of_yojson + _field_yojson + in + dune_diagnostics_field := Ppx_yojson_conv_lib.Option.Some fvalue + | Ppx_yojson_conv_lib.Option.Some _ -> + duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates) | _ -> ()); iter tail | [] -> () @@ -205,9 +291,10 @@ let t_of_yojson = (Ppx_yojson_conv_lib.( ! ) extra) yojson | [] -> - let codelens_value, extended_hover_value = + let codelens_value, extended_hover_value, dune_diagnostics_value = ( Ppx_yojson_conv_lib.( ! ) codelens_field - , Ppx_yojson_conv_lib.( ! ) extended_hover_field ) + , Ppx_yojson_conv_lib.( ! ) extended_hover_field + , Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field ) in { codelens = (match codelens_value with @@ -217,6 +304,10 @@ let t_of_yojson = (match extended_hover_value with | Ppx_yojson_conv_lib.Option.None -> None | Ppx_yojson_conv_lib.Option.Some v -> v) + ; dune_diagnostics = + (match dune_diagnostics_value with + | Ppx_yojson_conv_lib.Option.None -> None + | Ppx_yojson_conv_lib.Option.Some v -> v) })) | _ as yojson -> Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom @@ -228,8 +319,21 @@ let _ = t_of_yojson let yojson_of_t = (function - | { codelens = v_codelens; extended_hover = v_extended_hover } -> + | { codelens = v_codelens + ; extended_hover = v_extended_hover + ; dune_diagnostics = v_dune_diagnostics + } -> let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in + let bnds = + if None = v_dune_diagnostics then bnds + else + let arg = + (Json.Nullable_option.yojson_of_t DuneDiagnostics.yojson_of_t) + v_dune_diagnostics + in + let bnd = ("duneDiagnostics", arg) in + bnd :: bnds + in let bnds = if None = v_extended_hover then bnds else @@ -259,4 +363,5 @@ let _ = yojson_of_t let default = { codelens = Some { enable = false } ; extended_hover = Some { enable = false } + ; dune_diagnostics = Some { enable = true } } diff --git a/ocaml-lsp-server/src/configuration.ml b/ocaml-lsp-server/src/configuration.ml index 4b8201568..41020b923 100644 --- a/ocaml-lsp-server/src/configuration.ml +++ b/ocaml-lsp-server/src/configuration.ml @@ -47,3 +47,8 @@ let update t { DidChangeConfigurationParams.settings } = in let data = Config_data.t_of_yojson settings in Fiber.return { wheel; data } + +let report_dune_diagnostics t = + match t.data.dune_diagnostics with + | Some { enable = true } | None -> true + | Some { enable = false } -> false diff --git a/ocaml-lsp-server/src/configuration.mli b/ocaml-lsp-server/src/configuration.mli index 16e01c56f..fb6d8e4e5 100644 --- a/ocaml-lsp-server/src/configuration.mli +++ b/ocaml-lsp-server/src/configuration.mli @@ -10,3 +10,5 @@ val default : unit -> t Fiber.t val wheel : t -> Lev_fiber.Timer.Wheel.t val update : t -> DidChangeConfigurationParams.t -> t Fiber.t + +val report_dune_diagnostics : t -> bool diff --git a/ocaml-lsp-server/src/diagnostics.ml b/ocaml-lsp-server/src/diagnostics.ml index 8c8d8adc7..3864cafc8 100644 --- a/ocaml-lsp-server/src/diagnostics.ml +++ b/ocaml-lsp-server/src/diagnostics.ml @@ -87,9 +87,11 @@ type t = ; mutable dirty_uris : Uri_set.t ; related_information : bool ; tags : DiagnosticTag.t list + ; mutable report_dune_diagnostics : bool } -let create (capabilities : PublishDiagnosticsClientCapabilities.t option) send = +let create (capabilities : PublishDiagnosticsClientCapabilities.t option) send + ~report_dune_diagnostics = let related_information, tags = match capabilities with | None -> (false, []) @@ -105,6 +107,7 @@ let create (capabilities : PublishDiagnosticsClientCapabilities.t option) send = ; send ; related_information ; tags + ; report_dune_diagnostics } let send = @@ -157,11 +160,12 @@ let send = { d with source } else fun _pid x -> x in - Table.foldi ~init:() t.dune ~f:(fun dune per_dune () -> - Table.iter per_dune ~f:(fun (uri, diagnostic) -> - if Uri_set.mem dirty_uris uri then - let diagnostic = set_dune_source dune.pid diagnostic in - add_dune_diagnostic pending uri diagnostic)); + if t.report_dune_diagnostics then + Table.foldi ~init:() t.dune ~f:(fun dune per_dune () -> + Table.iter per_dune ~f:(fun (uri, diagnostic) -> + if Uri_set.mem dirty_uris uri then + let diagnostic = set_dune_source dune.pid diagnostic in + add_dune_diagnostic pending uri diagnostic)); t.dirty_uris <- (match which with | `All -> Uri_set.empty @@ -359,3 +363,14 @@ let merlin_diagnostics diagnostics merlin = Range.compare d1.range d2.range)) in set diagnostics (`Merlin (uri, all_diagnostics)) + +let set_report_dune_diagnostics t ~report_dune_diagnostics = + let open Fiber.O in + let* () = Fiber.return () in + if t.report_dune_diagnostics = report_dune_diagnostics then Fiber.return () + else ( + t.report_dune_diagnostics <- report_dune_diagnostics; + Table.iter t.dune ~f:(fun per_dune -> + Table.iter per_dune ~f:(fun (uri, _diagnostic) -> + t.dirty_uris <- Uri_set.add t.dirty_uris uri)); + send t `All) diff --git a/ocaml-lsp-server/src/diagnostics.mli b/ocaml-lsp-server/src/diagnostics.mli index 479df31ac..4ae6af57e 100644 --- a/ocaml-lsp-server/src/diagnostics.mli +++ b/ocaml-lsp-server/src/diagnostics.mli @@ -9,6 +9,7 @@ type t val create : PublishDiagnosticsClientCapabilities.t option -> (PublishDiagnosticsParams.t list -> unit Fiber.t) + -> report_dune_diagnostics:bool -> t val send : t -> [ `All | `One of Uri.t ] -> unit Fiber.t @@ -36,6 +37,9 @@ val tags_of_message : val merlin_diagnostics : t -> Document.Merlin.t -> unit Fiber.t +val set_report_dune_diagnostics : + t -> report_dune_diagnostics:bool -> unit Fiber.t + (** Exposed for testing *) val equal_message : string -> string -> bool diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index ef4ac1370..a734224fa 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -209,7 +209,11 @@ let on_initialize server (ip : InitializeParams.t) = let state : State.t = Server.state server in let workspaces = Workspaces.create ip in let diagnostics = + let report_dune_diagnostics = + Configuration.report_dune_diagnostics state.configuration + in Diagnostics.create + ~report_dune_diagnostics (let open Option.O in let* td = ip.capabilities.textDocument in td.publishDiagnostics) @@ -702,7 +706,15 @@ let on_notification server (notification : Client_notification.t) : state | CancelRequest _ -> Fiber.return state | ChangeConfiguration req -> - let+ configuration = Configuration.update state.configuration req in + let* configuration = Configuration.update state.configuration req in + let+ () = + let report_dune_diagnostics = + Configuration.report_dune_diagnostics configuration + in + Diagnostics.set_report_dune_diagnostics + ~report_dune_diagnostics + (State.diagnostics state) + in { state with configuration } | DidSaveTextDocument { textDocument = { uri }; _ } -> ( let state = Server.state server in