Add flag to disable dune diagnostics (#1221)

* add config to control dune diagnostics

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

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 }
 }
 ```

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 }
   }

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

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

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)

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

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