Merge branch 'master' into louis/hover-verbosity

* master: chore(nix): update flakes (ocaml#915) chore(merlin): subrepo to submodule (ocaml#914) refactor: add signature_help mli (ocaml#913) fix: correctly use merlin's pipeline (ocaml#904) feature(lsp): add workspace/diagnostic/refresh (ocaml#910) refactor: add mli's to test helpers (ocaml#912) fix: client capabilities and diagnostics (ocaml#908) fix(lsp): respect diagnostic tag client capabilities (ocaml#909) refactor: related information in diagnostics (ocaml#907) test: update to show related information (ocaml#906) fix: offer related information only when supported (ocaml#905)
Khady · Nov 7, 2022 · b58637a · b58637a
2 parents f5447bc + 03ac987
commit b58637a
Show file tree

Hide file tree

Showing 1,036 changed files with 304 additions and 334,613 deletions.
diff --git a/.gitmodules b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "ocaml-lsp-server/vendor/merlin"]
+	path = ocaml-lsp-server/vendor/merlin
+	url = https://github.com/rgrinberg/merlin
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,3 +1,19 @@
+# 1.14.2
+
+## Fixes
+
+- Fix random requests failing after switching documents (#904, fixes #898)
+
+- Do not offer related diagnostic information unless the user enables in client
+  capabilities (#905)
+
+- Do not offer diagnostic tags unless the client supports them (#909)
+
+- Do not attach extra data to diagnostics unless the client supports this
+  (#910)
+
+- Use /bin/sh instead of /bin/bash. This fixes ocamllsp on NixOS
+
 # 1.14.1
 
 ## Fixes

diff --git a/flake.lock b/flake.lock
diff --git a/flake.nix b/flake.nix
@@ -10,18 +10,25 @@
       url = "github:ocaml/opam-repository";
       flake = false;
     };
-    git-subrepo-src = {
-      url =
-        "github:rgrinberg/git-subrepo?rev=8fb6be3fb1500ab845081fc26ecdb950e9c0438c";
-      flake = false;
-    };
   };
 
   outputs = { self, flake-utils, opam-nix, opam-repository, nixpkgs, ... }@inputs:
-    let package = "ocaml-lsp-server";
-    in flake-utils.lib.eachDefaultSystem (system:
+    let
+      package = "ocaml-lsp-server";
+      overlay = final: prev: {
+        ${package} = prev.${package}.overrideAttrs (_: {
+          # Do not add share/nix-support, so that dependencies from
+          # the scope don't leak into dependent derivations
+          doNixSupport = false;
+        });
+        dune-release = prev.dune-release.overrideAttrs (_: {
+          doCheck = false;
+        });
+      };
+    in
+    flake-utils.lib.eachDefaultSystem (system:
       let
-        pkgs = nixpkgs.legacyPackages.${system};
+        pkgs = import nixpkgs { overlays = [ overlay ]; inherit system; };
         on = opam-nix.lib.${system};
         localPackages = {
           jsonrpc = "*";
@@ -52,15 +59,6 @@
                   package
                   ./.
                   (allPackages);
-              overlay = final: prev: {
-                ${package} = prev.${package}.overrideAttrs (_: {
-                  # Do not add share/nix-support, so that dependencies from
-                  # the scope don't leak into dependent derivations
-                  doNixSupport = false;
-                });
-                git-subrepo = prev.git-subrepo.overrideAttr
-                  (old: { src = inputs.git-subrepo-src; });
-              };
             in
             scope.overrideScope' overlay
           );
@@ -75,7 +73,6 @@
             buildInputs = (with pkgs;
               [
                 # dev tools
-                git-subrepo
                 ocamlformat_0_21_0
                 yarn
                 dune-release

diff --git a/lsp/src/server_request.ml b/lsp/src/server_request.ml
@@ -16,6 +16,7 @@ type _ t =
   | WorkDoneProgressCreate : WorkDoneProgressCreateParams.t -> unit t
   | CodeLensRefresh : unit t
   | SemanticTokensRefresh : unit t
+  | WorkspaceDiagnosticRefresh : unit t
   | UnknownRequest : string * Jsonrpc.Structured.t option -> Json.t t
 
 type packed = E : 'r t -> packed
@@ -32,6 +33,7 @@ let method_ (type a) (t : a t) =
   | WorkDoneProgressCreate _ -> "window/workDoneProgress/create"
   | CodeLensRefresh -> "workspace/codeLens/refresh"
   | SemanticTokensRefresh -> "workspace/semanticTokens/refresh"
+  | WorkspaceDiagnosticRefresh -> "workspace/diagnostic/refresh"
   | UnknownRequest (r, _) -> r
 
 let params =
@@ -54,6 +56,7 @@ let params =
       ret (WorkDoneProgressCreateParams.yojson_of_t params)
     | CodeLensRefresh -> None
     | SemanticTokensRefresh -> None
+    | WorkspaceDiagnosticRefresh -> None
     | UnknownRequest (_, params) -> params
 
 let to_jsonrpc_request t ~id =
@@ -105,6 +108,7 @@ let yojson_of_result (type a) (t : a t) (r : a) : Json.t =
   | ShowDocumentRequest _, r -> ShowDocumentResult.yojson_of_t r
   | CodeLensRefresh, _ -> `Null
   | SemanticTokensRefresh, _ -> `Null
+  | WorkspaceDiagnosticRefresh, _ -> `Null
   | UnknownRequest (_, _), json -> json
 
 let response_of_json (type a) (t : a t) (json : Json.t) : a =
@@ -120,4 +124,5 @@ let response_of_json (type a) (t : a t) (json : Json.t) : a =
   | WorkDoneProgressCreate _ -> unit_of_yojson json
   | CodeLensRefresh -> unit_of_yojson json
   | SemanticTokensRefresh -> unit_of_yojson json
+  | WorkspaceDiagnosticRefresh -> unit_of_yojson json
   | UnknownRequest (_, _) -> json
diff --git a/lsp/src/server_request.mli b/lsp/src/server_request.mli
@@ -16,6 +16,7 @@ type _ t =
   | WorkDoneProgressCreate : WorkDoneProgressCreateParams.t -> unit t
   | CodeLensRefresh : unit t
   | SemanticTokensRefresh : unit t
+  | WorkspaceDiagnosticRefresh : unit t
   | UnknownRequest : string * Jsonrpc.Structured.t option -> Json.t t
 
 type packed = E : 'r t -> packed

diff --git a/ocaml-lsp-server/src/diagnostics.ml b/ocaml-lsp-server/src/diagnostics.ml
@@ -86,16 +86,30 @@ type t =
   ; merlin : (Uri.t, Diagnostic.t list) Table.t
   ; send : PublishDiagnosticsParams.t list -> unit Fiber.t
   ; mutable dirty_uris : Uri_set.t
+  ; related_information : bool
+  ; tags : DiagnosticTag.t list
   }
 
 let workspace_root t = Lazy.force t.workspace_root
 
-let create send ~workspace_root =
+let create (capabilities : PublishDiagnosticsClientCapabilities.t option)
+    ~workspace_root send =
+  let related_information, tags =
+    match capabilities with
+    | None -> (false, [])
+    | Some c -> (
+      ( Option.value ~default:false c.relatedInformation
+      , match c.tagSupport with
+        | None -> []
+        | Some { valueSet } -> valueSet ))
+  in
   { dune = Table.create (module Dune) 32
   ; merlin = Table.create (module Uri) 32
   ; dirty_uris = Uri_set.empty
   ; send
   ; workspace_root
+  ; related_information
+  ; tags
   }
 
 let send =
@@ -199,18 +213,20 @@ let disconnect t dune =
              t.dirty_uris <- Uri_set.add t.dirty_uris uri);
          Table.remove t.dune dune)
 
-(* this is not inlined in [tags_of_message] for reusability *)
-let diagnostic_tags_unnecessary = Some [ DiagnosticTag.Unnecessary ]
-
-let tags_of_message ~src message =
-  match src with
-  | `Dune when String.is_prefix message ~prefix:"unused" ->
-    diagnostic_tags_unnecessary
-  | `Merlin when Diagnostic_util.is_unused_var_warning message ->
-    diagnostic_tags_unnecessary
-  | `Merlin when Diagnostic_util.is_deprecated_warning message ->
-    Some [ DiagnosticTag.Deprecated ]
-  | `Dune | `Merlin -> None
+let tags_of_message =
+  let tags_of_message ~src message : DiagnosticTag.t option =
+    match src with
+    | `Dune when String.is_prefix message ~prefix:"unused" -> Some Unnecessary
+    | `Merlin when Diagnostic_util.is_unused_var_warning message ->
+      Some Unnecessary
+    | `Merlin when Diagnostic_util.is_deprecated_warning message ->
+      Some Deprecated
+    | `Dune | `Merlin -> None
+  in
+  fun t ~src message ->
+    match tags_of_message ~src message with
+    | None -> None
+    | Some tag -> Option.some_if (List.mem t.tags tag ~equal:Poly.equal) [ tag ]
 
 let extract_related_errors uri raw_message =
   match Ocamlc_loc.parse_raw raw_message with
@@ -292,22 +308,27 @@ 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)) )
+                  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 ~src:`Merlin message in
+                let tags = tags_of_message diagnostics ~src:`Merlin message in
                 create_diagnostic
                   ?tags
                   ?relatedInformation

diff --git 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
@@ -34,7 +35,7 @@ val remove :
 val disconnect : t -> Dune.t -> unit
 
 val tags_of_message :
-  src:[< `Dune | `Merlin ] -> string -> DiagnosticTag.t list option
+  t -> src:[< `Dune | `Merlin ] -> string -> DiagnosticTag.t list option
 
 val merlin_diagnostics : t -> Document.Merlin.t -> unit Fiber.t