Shorten Merlin diagnostics error (#1513)

* Add ShortenMerlinDiagnostics in `config_data` (and promote)

* Upgrade configuration

* Change diagnostics representation

* Add test

* Remove useless `Fiber.return`

* Add CHANGES entry

* Restore Merlin's recovery

Author: xvw

CHANGES.md

@@ -5,6 +5,7 @@
 - Make `inlay-hint` for function parameters configurable (#1515)
 - Add custom `ocamllsp/jumpToTypedHole` to navigate through typed holes (#1516)
 - Add a code-action for combining pattern cases (just relaying on regex) (#1514)
+- Allow (by configuration) shortening of diagnostics (just highlighting the first line) (#1513)
 
 ## Fixes
 

ocaml-lsp-server/src/config_data.ml

@@ -1,6 +1,78 @@
 open Import
 open Import.Json.Conv
 
+module ShortenMerlinDiagnostics = struct
+  type t = { enable : bool [@default false] }
+  [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
+
+  let _ = fun (_ : t) -> ()
+
+  let t_of_yojson =
+    (let _tp_loc = "ocaml-lsp-server/src/config_data.ml.ShortenMerlinDiagnostics.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 -> false
+                  | 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
+
 module InlayHints = struct
   type t =
     { hint_pattern_variables : bool [@key "hintPatternVariables"] [@default false]
@@ -565,6 +637,8 @@ type t =
         [@key "syntaxDocumentation"] [@default None] [@yojson_drop_default ( = )]
   ; merlin_jump_code_actions : MerlinJumpCodeActions.t Json.Nullable_option.t
         [@key "merlinJumpCodeActions"] [@default None] [@yojson_drop_default ( = )]
+  ; shorten_merlin_diagnostics : ShortenMerlinDiagnostics.t Json.Nullable_option.t
+        [@key "shortenMerlinDiagnostics"] [@default None] [@yojson_drop_default ( = )]
   }
 [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
 
@@ -581,6 +655,7 @@ let t_of_yojson =
      and dune_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None
      and syntax_documentation_field = ref Ppx_yojson_conv_lib.Option.None
      and merlin_jump_code_actions_field = ref Ppx_yojson_conv_lib.Option.None
+     and shorten_merlin_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None
      and duplicates = ref []
      and extra = ref [] in
      let rec iter = function
@@ -655,6 +730,17 @@ let t_of_yojson =
                merlin_jump_code_actions_field := Ppx_yojson_conv_lib.Option.Some fvalue
              | Ppx_yojson_conv_lib.Option.Some _ ->
                duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
+          | "shortenMerlinDiagnostics" ->
+            (match Ppx_yojson_conv_lib.( ! ) shorten_merlin_diagnostics_field with
+             | Ppx_yojson_conv_lib.Option.None ->
+               let fvalue =
+                 Json.Nullable_option.t_of_yojson
+                   ShortenMerlinDiagnostics.t_of_yojson
+                   _field_yojson
+               in
+               shorten_merlin_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
        | [] -> ()
@@ -680,15 +766,17 @@ let t_of_yojson =
                , inlay_hints_value
                , dune_diagnostics_value
                , syntax_documentation_value
-               , merlin_jump_code_actions_value )
+               , merlin_jump_code_actions_value
+               , shorten_merlin_diagnostics_value )
              =
              ( Ppx_yojson_conv_lib.( ! ) codelens_field
              , Ppx_yojson_conv_lib.( ! ) extended_hover_field
              , Ppx_yojson_conv_lib.( ! ) standard_hover_field
              , Ppx_yojson_conv_lib.( ! ) inlay_hints_field
              , Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field
              , Ppx_yojson_conv_lib.( ! ) syntax_documentation_field
-             , Ppx_yojson_conv_lib.( ! ) merlin_jump_code_actions_field )
+             , Ppx_yojson_conv_lib.( ! ) merlin_jump_code_actions_field
+             , Ppx_yojson_conv_lib.( ! ) shorten_merlin_diagnostics_field )
            in
            { codelens =
                (match codelens_value with
@@ -718,6 +806,10 @@ let t_of_yojson =
                (match merlin_jump_code_actions_value with
                 | Ppx_yojson_conv_lib.Option.None -> None
                 | Ppx_yojson_conv_lib.Option.Some v -> v)
+           ; shorten_merlin_diagnostics =
+               (match shorten_merlin_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 _tp_loc yojson
@@ -735,8 +827,20 @@ let yojson_of_t =
      ; dune_diagnostics = v_dune_diagnostics
      ; syntax_documentation = v_syntax_documentation
      ; merlin_jump_code_actions = v_merlin_jump_code_actions
+     ; shorten_merlin_diagnostics = v_shorten_merlin_diagnostics
      } ->
      let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
+     let bnds =
+       if None = v_shorten_merlin_diagnostics
+       then bnds
+       else (
+         let arg =
+           (Json.Nullable_option.yojson_of_t ShortenMerlinDiagnostics.yojson_of_t)
+             v_shorten_merlin_diagnostics
+         in
+         let bnd = "shortenMerlinDiagnostics", arg in
+         bnd :: bnds)
+     in
      let bnds =
        if None = v_merlin_jump_code_actions
        then bnds
@@ -829,5 +933,6 @@ let default =
   ; dune_diagnostics = Some { enable = true }
   ; syntax_documentation = Some { enable = false }
   ; merlin_jump_code_actions = Some { enable = false }
+  ; shorten_merlin_diagnostics = Some { enable = false }
   }
 ;;

ocaml-lsp-server/src/configuration.ml

@@ -55,3 +55,9 @@ let report_dune_diagnostics t =
   | Some { enable = true } | None -> true
   | Some { enable = false } -> false
 ;;
+
+let shorten_merlin_diagnostics t =
+  match t.data.shorten_merlin_diagnostics with
+  | Some { enable = true } -> true
+  | Some { enable = false } | None -> false
+;;

ocaml-lsp-server/src/configuration.mli

@@ -9,3 +9,4 @@ 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
+val shorten_merlin_diagnostics : t -> bool

ocaml-lsp-server/src/diagnostics.ml

@@ -86,12 +86,14 @@ type t =
   ; related_information : bool
   ; tags : DiagnosticTag.t list
   ; mutable report_dune_diagnostics : bool
+  ; mutable shorten_merlin_diagnostics : bool
   }
 
 let create
       (capabilities : PublishDiagnosticsClientCapabilities.t option)
       send
       ~report_dune_diagnostics
+      ~shorten_merlin_diagnostics
   =
   let related_information, tags =
     match capabilities with
@@ -109,6 +111,7 @@ let create
   ; related_information
   ; tags
   ; report_dune_diagnostics
+  ; shorten_merlin_diagnostics
   }
 ;;
 
@@ -286,6 +289,74 @@ let extract_related_errors uri raw_message =
   | _ -> raw_message, None
 ;;
 
+let first_n_lines_of_range (range : Range.t) n =
+  if range.end_.line - range.start.line < n
+  then range
+  else (
+    let start = Position.create ~character:range.start.character ~line:range.start.line
+    and end_ = Position.create ~character:0 ~line:(range.start.line + n) in
+    Range.create ~start ~end_)
+;;
+
+let error_to_diagnostics ~diagnostics ~merlin error =
+  let doc = Document.Merlin.to_doc merlin in
+  let create_diagnostic = Diagnostic.create ~source:ocamllsp_source in
+  let uri = Document.uri doc in
+  let loc = Loc.loc_of_report error in
+  let original_range = Range.of_loc loc in
+  let range =
+    if diagnostics.shorten_merlin_diagnostics
+    then first_n_lines_of_range original_range 1
+    else original_range
+  in
+  let severity =
+    match error.source with
+    | Warning -> DiagnosticSeverity.Warning
+    | _ -> DiagnosticSeverity.Error
+  in
+  let make_message ppf m = String.trim (Format.asprintf "%a@." ppf m) in
+  let message = make_message Loc.print_main error in
+  let message, related_information =
+    match diagnostics.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 maybe_extra_range_information =
+    match diagnostics.shorten_merlin_diagnostics with
+    | false -> None
+    | true ->
+      let start_location = Location.create ~range:original_range ~uri in
+      Some
+        [ DiagnosticRelatedInformation.create
+            ~location:start_location
+            ~message:"Original error span"
+        ]
+  in
+  let relatedInformation =
+    Option.merge maybe_extra_range_information related_information ~f:( @ )
+  in
+  let tags = tags_of_message diagnostics ~src:`Merlin message in
+  create_diagnostic
+    ?tags
+    ?relatedInformation
+    ~range
+    ~message:(`String message)
+    ~severity
+    ()
+;;
+
 let merlin_diagnostics diagnostics merlin =
   let doc = Document.Merlin.to_doc merlin in
   let uri = Document.uri doc in
@@ -307,41 +378,7 @@ let merlin_diagnostics diagnostics merlin =
         [ create_diagnostic ~range:Range.first_line ~message () ]
       | errors ->
         let merlin_diagnostics =
-          List.rev_map errors ~f:(fun (error : Loc.error) ->
-            let loc = Loc.loc_of_report error in
-            let range = Range.of_loc loc in
-            let severity =
-              match error.source with
-              | Warning -> DiagnosticSeverity.Warning
-              | _ -> DiagnosticSeverity.Error
-            in
-            let make_message ppf m = String.trim (Format.asprintf "%a@." ppf m) in
-            let message = make_message Loc.print_main error in
-            let message, relatedInformation =
-              match diagnostics.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 diagnostics ~src:`Merlin message in
-            create_diagnostic
-              ?tags
-              ?relatedInformation
-              ~range
-              ~message:(`String message)
-              ~severity
-              ())
+          List.rev_map errors ~f:(error_to_diagnostics ~diagnostics ~merlin)
         in
         let holes_as_err_diags =
           Query_commands.dispatch pipeline Holes
@@ -369,8 +406,6 @@ let merlin_diagnostics diagnostics merlin =
 ;;
 
 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 (
@@ -380,3 +415,14 @@ let set_report_dune_diagnostics t ~report_dune_diagnostics =
         t.dirty_uris <- Uri_set.add t.dirty_uris uri));
     send t `All)
 ;;
+
+let set_shorten_merlin_diagnostics t ~shorten_merlin_diagnostics =
+  if t.shorten_merlin_diagnostics = shorten_merlin_diagnostics
+  then Fiber.return ()
+  else (
+    t.shorten_merlin_diagnostics <- shorten_merlin_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 @@ val create
   :  PublishDiagnosticsClientCapabilities.t option
   -> (PublishDiagnosticsParams.t list -> unit Fiber.t)
   -> report_dune_diagnostics:bool
+  -> shorten_merlin_diagnostics:bool
   -> t
 
 val send : t -> [ `All | `One of Uri.t ] -> unit Fiber.t
@@ -37,6 +38,7 @@ 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
+val set_shorten_merlin_diagnostics : t -> shorten_merlin_diagnostics:bool -> unit Fiber.t
 
 (** Exposed for testing *)