Add a new option to mute the hover response. (#1416)

* Add option to mute the hover + ensure jump CA is disabled

Author: voodoos

CHANGES.md

@@ -1,3 +1,11 @@
+# Unreleased
+
+## Features
+
+- Add a new server option `standardHover`, that can be used by clients to
+  disable the default hover provider.  When `standardHover = false`
+  `textDocument/hover` requests always returns with empty result.
+
 # 1.20.1
 
 ## Fixes

ocaml-lsp-server/src/config_data.ml

@@ -241,6 +241,78 @@ module ExtendedHover = struct
   [@@@end]
 end
 
+module StandardHover = 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.StandardHover.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
+
 module DuneDiagnostics = struct
   type t = { enable : bool [@default true] }
   [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
@@ -461,6 +533,8 @@ 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 ( = )]
+  ; standard_hover : StandardHover.t Json.Nullable_option.t
+       [@key "standardHover"] [@default None] [@yojson_drop_default ( = )]
   ; inlay_hints : InlayHints.t Json.Nullable_option.t
        [@key "inlayHints"] [@default None] [@yojson_drop_default ( = )]
   ; dune_diagnostics : DuneDiagnostics.t Json.Nullable_option.t
@@ -480,6 +554,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 standard_hover_field = ref Ppx_yojson_conv_lib.Option.None
      and inlay_hints_field = ref Ppx_yojson_conv_lib.Option.None
      and dune_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None
      and syntax_documentation_field = ref Ppx_yojson_conv_lib.Option.None
@@ -507,6 +582,15 @@ 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)
+          | "standardHover" ->
+            (match Ppx_yojson_conv_lib.( ! ) standard_hover_field with
+             | Ppx_yojson_conv_lib.Option.None ->
+               let fvalue =
+                 Json.Nullable_option.t_of_yojson StandardHover.t_of_yojson _field_yojson
+               in
+               standard_hover_field := Ppx_yojson_conv_lib.Option.Some fvalue
+             | Ppx_yojson_conv_lib.Option.Some _ ->
+               duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
           | "inlayHints" ->
             (match Ppx_yojson_conv_lib.( ! ) inlay_hints_field with
              | Ppx_yojson_conv_lib.Option.None ->
@@ -570,13 +654,15 @@ let t_of_yojson =
          | [] ->
            let ( codelens_value
                , extended_hover_value
+               , standard_hover_value
                , inlay_hints_value
                , dune_diagnostics_value
                , syntax_documentation_value
                , merlin_jump_code_actions_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
@@ -590,6 +676,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)
+           ; standard_hover =
+               (match standard_hover_value with
+                | Ppx_yojson_conv_lib.Option.None -> None
+                | Ppx_yojson_conv_lib.Option.Some v -> v)
            ; inlay_hints =
                (match inlay_hints_value with
                 | Ppx_yojson_conv_lib.Option.None -> None
@@ -618,6 +708,7 @@ let yojson_of_t =
   (function
    | { codelens = v_codelens
      ; extended_hover = v_extended_hover
+     ; standard_hover = v_standard_hover
      ; inlay_hints = v_inlay_hints
      ; dune_diagnostics = v_dune_diagnostics
      ; syntax_documentation = v_syntax_documentation
@@ -667,6 +758,16 @@ let yojson_of_t =
          let bnd = "inlayHints", arg in
          bnd :: bnds)
      in
+     let bnds =
+       if None = v_standard_hover
+       then bnds
+       else (
+         let arg =
+           (Json.Nullable_option.yojson_of_t StandardHover.yojson_of_t) v_standard_hover
+         in
+         let bnd = "standardHover", arg in
+         bnd :: bnds)
+     in
      let bnds =
        if None = v_extended_hover
        then bnds
@@ -696,9 +797,10 @@ let _ = yojson_of_t
 let default =
   { codelens = Some { enable = false }
   ; extended_hover = Some { enable = false }
+  ; standard_hover = Some { enable = true }
   ; inlay_hints = Some { hint_pattern_variables = false; hint_let_bindings = false }
   ; dune_diagnostics = Some { enable = true }
   ; syntax_documentation = Some { enable = false }
-  ; merlin_jump_code_actions = Some { enable = true }
+  ; merlin_jump_code_actions = Some { enable = false }
   }
 ;;

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -628,12 +628,15 @@ let on_request
   | TextDocumentColor _ -> now []
   | TextDocumentColorPresentation _ -> now []
   | TextDocumentHover req ->
-    let mode =
-      match state.configuration.data.extended_hover with
-      | Some { enable = true } -> Hover_req.Extended_variable
-      | Some _ | None -> Hover_req.Default
-    in
-    later (fun (_ : State.t) () -> Hover_req.handle rpc req mode) ()
+    (match state.configuration.data.standard_hover with
+     | Some { enable = false } -> now None
+     | Some { enable = true } | None ->
+       let mode =
+         match state.configuration.data.extended_hover with
+         | Some { enable = true } -> Hover_req.Extended_variable
+         | Some _ | None -> Hover_req.Default
+       in
+       later (fun (_ : State.t) () -> Hover_req.handle rpc req mode) ())
   | TextDocumentReferences req -> later (references rpc) req
   | TextDocumentCodeLensResolve codeLens -> now codeLens
   | TextDocumentCodeLens req ->

ocaml-lsp-server/test/e2e-new/code_actions.ml

@@ -1272,6 +1272,14 @@ module M : sig type t = I of int | B of bool end
     |}]
 ;;
 
+let activate_jump client =
+  let config =
+    DidChangeConfigurationParams.create
+      ~settings:(`Assoc [ "merlinJumpCodeActions", `Assoc [ "enable", `Bool true ] ])
+  in
+  change_config ~client config
+;;
+
 let%expect_test "can jump to match target" =
   let source =
     {ocaml|
@@ -1288,7 +1296,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:5 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-match");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-match");
   [%expect
     {|
     Code actions:
@@ -1327,7 +1339,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:5 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-next-case");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-next-case");
   [%expect
     {|
     Code actions:
@@ -1364,7 +1380,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:5 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-prev-case");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-prev-case");
   [%expect
     {|
     Code actions:
@@ -1401,7 +1421,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:5 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-let");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-let");
   [%expect
     {|
     Code actions:
@@ -1438,7 +1462,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:5 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-fun");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-fun");
   [%expect
     {|
     Code actions:
@@ -1476,7 +1504,11 @@ let f (x : t) (d : bool) =
     let end_ = Position.create ~line:2 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-module");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-module");
   [%expect
     {|
     Code actions:
@@ -1517,7 +1549,11 @@ let%expect_test "can jump to module-type target" =
     let end_ = Position.create ~line:4 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-module-type");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-module-type");
   [%expect
     {|
       Code actions:
@@ -1553,7 +1589,11 @@ let%expect_test "shouldn't find the jump target on the same line" =
     let end_ = Position.create ~line:0 ~character:5 in
     Range.create ~start ~end_
   in
-  print_code_actions source range ~filter:(find_action "merlin-jump-fun");
+  print_code_actions
+    ~prep:activate_jump
+    source
+    range
+    ~filter:(find_action "merlin-jump-fun");
   [%expect {|
       No code actions |}]
 ;;

ocaml-lsp-server/test/e2e-new/lsp_helpers.ml

@@ -1,5 +1,7 @@
 open Test.Import
 
+let change_config ~client params = Client.notification client (ChangeConfiguration params)
+
 let open_document ~client ~uri ~source =
   let textDocument =
     TextDocumentItem.create ~uri ~languageId:"ocaml" ~version:0 ~text:source

ocaml-lsp-server/test/e2e-new/lsp_helpers.mli

@@ -1,5 +1,8 @@
 open Test.Import
 
+(** Send the given configuration to the language server *)
+val change_config : client:'a Client.t -> DidChangeConfigurationParams.t -> unit Fiber.t
+
 (** Opens a document with the language server. This must be done before trying
     to access it *)
 val open_document

ocaml-lsp-server/test/e2e-new/syntax_doc_tests.ml

@@ -1,6 +1,6 @@
 open! Test.Import
+open Lsp_helpers
 
-let change_config client params = Client.notification client (ChangeConfiguration params)
 let uri = DocumentUri.of_path "test.ml"
 let create_postion line character = Position.create ~line ~character
 
@@ -67,7 +67,7 @@ type color = Red|Blue
 |ocaml} in
   let position = create_postion 1 9 in
   let req client =
-    let* () = change_config client activate_syntax_doc in
+    let* () = change_config ~client activate_syntax_doc in
     let* resp = hover_req client position in
     let () = print_hover resp in
     Fiber.return ()
@@ -94,7 +94,7 @@ type color = Red|Blue
 |ocaml} in
   let position = create_postion 1 9 in
   let req client =
-    let* () = change_config client deactivate_syntax_doc in
+    let* () = change_config ~client deactivate_syntax_doc in
     let* resp = hover_req client position in
     let () = print_hover resp in
     Fiber.return ()
@@ -117,7 +117,7 @@ type t = ..
 |ocaml} in
   let position = create_postion 1 5 in
   let req client =
-    let* () = change_config client activate_syntax_doc in
+    let* () = change_config ~client activate_syntax_doc in
     let* resp = hover_req client position in
     let () = print_hover resp in
     Fiber.return ()
@@ -143,7 +143,7 @@ let%expect_test "should receive no hover response" =
   |ocaml} in
   let position = create_postion 1 5 in
   let req client =
-    let* () = change_config client activate_syntax_doc in
+    let* () = change_config ~client activate_syntax_doc in
     let* resp = hover_req client position in
     let () = print_hover resp in
     Fiber.return ()