add a custom ocamllsp/hoverExtend request

ocaml-lsp-server/docs/ocamllsp/hoverExtended-spec.md

@@ -0,0 +1,52 @@
+#### Hover Extended
+
+Alternative hover command providing additional information.
+
+This command is has support for variable verbosity.
+
+```ocaml
+type t = int
+let x : t = 1
+```
+
+With the cursor on the value `x`, a call with a verbosity of 0 or lower would return `t` making it equivalent to a call to `textDocument/hover`. A call with a verbosity of 1 would return `int`.
+
+The management of the verbosity is left to the clients to implement.
+
+##### Client capability
+
+nothing that should be noted
+
+##### Server capability
+
+property name: `handleHoverExtended`
+property type: `boolean`
+
+##### Request
+
+- method: `ocamllsp/hoverExtended`
+- params:
+
+  ```json
+  {
+    "uri": DocumentUri,
+    "position": Position,
+    "verbosity": integer
+  }
+  ```
+
+##### Response
+
+The response is similar to the one of `textDocument/hover`
+
+```typescript
+	/**
+	 * The hover's content
+	 */
+	contents: MarkedString | MarkedString[] | MarkupContent;
+	/**
+	 * An optional range is a range inside a text document
+	 * that is used to visualize a hover, e.g. by changing the background color.
+	 */
+	range?: Range;
+```

ocaml-lsp-server/src/custom_requests/req_hover_extended.ml

@@ -0,0 +1,116 @@
+open Import
+open Fiber.O
+
+let capability = ("handleHoverExtended", `Bool true)
+
+let meth = "ocamllsp/hoverExtended"
+
+module Request_params = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; cursor_position : Position.t
+    ; verbosity : int
+    }
+
+  let params_schema =
+    `Assoc
+      [ ("textDocument", `String "<TextDocumentIdentifier>")
+      ; ("position", `String "<Position>")
+      ; ("verbosity", `String "<integer>")
+      ]
+
+  let of_jsonrpc_params params : t option =
+    match params with
+    | `Assoc
+        [ ("textDocument", text_document)
+        ; ("position", position)
+        ; ("verbosity", verbosity)
+        ] ->
+      let text_document = TextDocumentIdentifier.t_of_yojson text_document in
+      let cursor_position = Position.t_of_yojson position in
+      let verbosity = Yojson.Safe.Util.to_int verbosity in
+      Some { text_document; cursor_position; verbosity }
+    | _ -> None
+
+  let of_jsonrpc_params_exn params : t =
+    let params_spec = { Custom_request.params_schema; of_jsonrpc_params } in
+    Custom_request.of_jsonrpc_params_exn params_spec params
+end
+
+let client_capabilities (state : State.t) =
+  (State.initialize_params state).capabilities
+
+(* TODO: duplicated with Hover_req.format_contents *)
+let format_contents ~syntax ~markdown ~typ ~doc =
+  (* TODO for vscode, we should just use the language id. But that will not work
+     for all editors *)
+  `MarkupContent
+    (if markdown then
+     let value =
+       let markdown_name = Document.Syntax.markdown_name syntax in
+       match doc with
+       | None -> sprintf "```%s\n%s\n```" markdown_name typ
+       | Some s ->
+         let doc =
+           match Doc_to_md.translate s with
+           | Raw d -> sprintf "(** %s *)" d
+           | Markdown d -> d
+         in
+         sprintf "```%s\n%s\n```\n---\n%s" markdown_name typ doc
+     in
+     { MarkupContent.value; kind = MarkupKind.Markdown }
+    else
+      let value =
+        match doc with
+        | None -> sprintf "%s" typ
+        | Some d -> sprintf "%s\n%s" typ d
+      in
+      { MarkupContent.value; kind = MarkupKind.PlainText })
+
+let hover (* server *) (state : State.t) text_document position verbosity =
+  let doc =
+    Document_store.get state.store text_document.TextDocumentIdentifier.uri
+  in
+  let pos = Position.logical position in
+  (* TODO we shouldn't be acquiring the merlin thread twice per request *)
+  let* type_enclosing = Document.type_enclosing ~verbosity doc pos in
+  match type_enclosing with
+  | None -> Fiber.return None
+  | Some { loc; typ; doc = documentation } ->
+    let syntax = Document.syntax doc in
+    let+ typ =
+      (* We ask Ocamlformat to format this type *)
+      let* result = Ocamlformat_rpc.format_type state.ocamlformat_rpc ~typ in
+      match result with
+      | Ok v ->
+        (* OCamlformat adds an unnecessay newline at the end of the type *)
+        Fiber.return (String.trim v)
+      | Error `No_process -> Fiber.return typ
+      | Error (`Msg _message) ->
+        (* We log OCamlformat errors and display the unformated type *)
+        (* TODO: how to obtain the server *)
+        (* let+ () = let message = sprintf "An error occured while querying
+           ocamlformat:\n\ Input type: %s\n\n\ Answer: %s" typ message in
+           State.log_msg server ~type_:Warning ~message in typ *)
+        Fiber.return typ
+    in
+    let contents =
+      let markdown =
+        let client_capabilities = State.client_capabilities state in
+        ClientCapabilities.markdown_support
+          client_capabilities
+          ~field:(fun td -> Option.map td.hover ~f:(fun h -> h.contentFormat))
+      in
+      format_contents ~syntax ~markdown ~typ ~doc:documentation
+    in
+    let range = Range.of_loc loc in
+    Some (Hover.create ~contents ~range ())
+
+let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) =
+  let { Request_params.text_document; cursor_position; verbosity } =
+    Request_params.of_jsonrpc_params_exn params
+  in
+  let+ hover = hover state text_document cursor_position verbosity in
+  match hover with
+  | None -> `Null
+  | Some hover -> Hover.yojson_of_t hover

ocaml-lsp-server/src/document.ml

@@ -275,9 +275,20 @@ type type_enclosing =
   ; doc : string option
   }
 
-let type_enclosing doc pos =
+let type_enclosing ?(verbosity = 0) doc pos =
   with_pipeline_exn doc (fun pipeline ->
       let command = Query_protocol.Type_enclosing (None, pos, None) in
+      let pipeline =
+        match verbosity with
+        | 0 -> pipeline
+        | verbosity ->
+          let source = source doc in
+          let config = Mpipeline.final_config pipeline in
+          let config =
+            { config with query = { config.query with verbosity } }
+          in
+          Mpipeline.make config source
+      in
       let res = Query_commands.dispatch pipeline command in
       match res with
       | [] | (_, `Index _, _) :: _ -> None

ocaml-lsp-server/src/document.mli

@@ -74,4 +74,5 @@ type type_enclosing =
   ; doc : string option
   }
 
-val type_enclosing : t -> Msource.position -> type_enclosing option Fiber.t
+val type_enclosing :
+  ?verbosity:int -> t -> Msource.position -> type_enclosing option Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -88,6 +88,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
               ; Req_typed_holes.capability
               ; Req_wrapping_ast_node.capability
               ; Dune.view_promotion_capability
+              ; Req_hover_extended.capability
               ] )
         ]
     in
@@ -705,6 +706,7 @@ let on_request :
       ; (Req_wrapping_ast_node.meth, Req_wrapping_ast_node.on_request)
       ; ( Semantic_highlighting.Debug.meth_request_full
         , Semantic_highlighting.Debug.on_request_full )
+      ; (Req_hover_extended.meth, Req_hover_extended.on_request)
       ]
       |> List.assoc_opt meth
     with

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

@@ -63,7 +63,8 @@ let%expect_test "start/stop" =
               "handleInferIntf": true,
               "handleTypedHoles": true,
               "handleWrappingAstNode": true,
-              "diagnostic_promotions": true
+              "diagnostic_promotions": true,
+              "handleHoverExtended": true
             }
           },
           "foldingRangeProvider": true,