Documentation custom query

CHANGES.md

@@ -44,6 +44,8 @@
 
 - Add custom [`ocamllsp/typeEnclosing`](https://github.com/ocaml/ocaml-lsp/blob/109801e56f2060caf4487427bede28b824f4f1fe/ocaml-lsp-server/docs/ocamllsp/typeEnclosing-spec.md) request (#1304)
 
+- Add custom [`ocamllsp/documentation`](/ocaml-lsp-server/docs/ocamllsp/documentation-spec.md) request (#1336)
+
 
 ## Fixes
 

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

@@ -0,0 +1,40 @@
+# Documentation Request
+
+## Description
+
+Merlin has a command `document` that gets `odoc` documentation for symbols based on a cursor position or an optional identifier. This request allows documentation to be gotten using a classic Merlin workflow.
+
+## Client capability
+
+```js
+export interface GetDocClientCapabilities {
+	contentFormat: MarkupKind[];
+}
+```
+- `contentFormat`: Client supports the following content formats if the content property refers to a `literal of type MarkupContent`. The order describes the preferred format of the client.
+
+## Request
+
+```js
+export interface GetDocParams extends TextDocumentPositionParams
+{
+    identifier?: string;
+    contentFormat?:MarkupKind;
+}
+```
+- `position`: The position of the cursor.
+- `identifier`: An optional identifier. If provided, documentation for this ident is looked up from the environment at the given position. Else the server will look for the documentation of the identifier under the cursor.
+- `contentFormat`: Optionally override the result's format. Could be `Plaintext` or `Markdown`.
+
+## Response
+
+```js
+result: GetDoc | null
+export interface GetDoc {
+    doc: MarkupContent;
+}
+
+```
+- `doc`: The documentation found
+- A response with null result is returned if the identifier doesn't have documentation.
+- An error is returned if the identifier is invalid.

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

@@ -0,0 +1,83 @@
+open Import
+module TextDocumentPositionParams = Lsp.Types.TextDocumentPositionParams
+
+let meth = "ocamllsp/documentation"
+
+let capability = ("handleDocumentation", `Bool true)
+
+module GetDocClientCapabilities = struct
+  type t = { contentFormat : MarkupKind.t list }
+
+  let yojson_of_t { contentFormat } =
+    `Assoc
+      (`List
+        (List.map
+           ~f:(fun format -> MarkupKind.yojson_of_t format)
+           contentFormat))
+end
+
+module GetDocParams = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; position : Position.t
+    ; identifier : string option
+    ; contentFormat : MarkupKind.t option
+    }
+
+  let t_of_yojson json =
+    let open Yojson.Safe.Util in
+    let textDocumentPosition =
+      Lsp.Types.TextDocumentPositionParams.t_of_yojson json
+    in
+    let identifier = json |> member "identifier" |> to_option to_string in
+    let contentFormat =
+      json |> member "contentFormat" |> to_option MarkupKind.t_of_yojson
+    in
+    { position = textDocumentPosition.position
+    ; text_document = textDocumentPosition.textDocument
+    ; identifier
+    ; contentFormat
+    }
+end
+
+module GetDoc = struct
+  type t = { doc : MarkupContent.t }
+
+  let yojson_of_t { doc } = `Assoc [ ("doc", MarkupContent.yojson_of_t doc) ]
+
+  let create ~kind ~value = MarkupContent.create ~kind ~value
+end
+
+type t = GetDoc.t
+
+let dispatch ~merlin ~position ~identifier ~contentFormat =
+  Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+      let position = Position.logical position in
+      let query = Query_protocol.Document (identifier, position) in
+      let result = Query_commands.dispatch pipeline query in
+      match result with
+      | `No_documentation | `Invalid_context | `Not_found _ -> `Null
+      | `Builtin value
+      | `File_not_found value
+      | `Found value
+      | `Not_in_env value ->
+        let markup_content =
+          match contentFormat with
+          | Some format -> GetDoc.create ~kind:format ~value
+          | None -> GetDoc.create ~kind:MarkupKind.PlainText ~value
+        in
+        GetDoc.yojson_of_t { doc = markup_content })
+
+let on_request ~params state =
+  Fiber.of_thunk (fun () ->
+      let params =
+        (Option.value ~default:(`Assoc []) params :> Yojson.Safe.t)
+      in
+      let GetDocParams.{ text_document; position; identifier; contentFormat } =
+        GetDocParams.t_of_yojson params
+      in
+      let uri = text_document.uri in
+      let doc = Document_store.get state.State.store uri in
+      match Document.kind doc with
+      | `Other -> Fiber.return `Null
+      | `Merlin merlin -> dispatch ~merlin ~position ~identifier ~contentFormat)

ocaml-lsp-server/src/custom_requests/req_documentation.mli

@@ -0,0 +1,22 @@
+open Import
+
+val meth : string
+
+val capability : string * [> `Bool of bool ]
+
+module GetDocClientCapabilities : sig
+  type t = { contentFormat : MarkupKind.t list }
+
+  val yojson_of_t : t -> [> `Assoc of [> `List of Json.t list ] ]
+end
+
+module GetDoc : sig
+  type t = { doc : MarkupContent.t }
+end
+
+type t = GetDoc.t
+
+val on_request :
+     params:[< Yojson.Safe.t > `Assoc ] option
+  -> State.t
+  -> [> `Assoc of (string * Yojson.Safe.t) list | `Null ] Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -100,6 +100,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
               ; Req_hover_extended.capability
               ; Req_merlin_call_compatible.capability
               ; Req_type_enclosing.capability
+              ; Req_documentation.capability
               ] )
         ]
     in
@@ -523,6 +524,7 @@ let on_request :
       ; (Req_typed_holes.meth, Req_typed_holes.on_request)
       ; (Req_merlin_call_compatible.meth, Req_merlin_call_compatible.on_request)
       ; (Req_type_enclosing.meth, Req_type_enclosing.on_request)
+      ; (Req_documentation.meth, Req_documentation.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 )

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

@@ -0,0 +1,173 @@
+open Test.Import
+
+module Util = struct
+  let call_documentation ~position ?(identifier = None) ?(contentFormat = None)
+      client =
+    let uri = DocumentUri.of_path "test.ml" in
+    let text_document =
+      TextDocumentIdentifier.yojson_of_t @@ TextDocumentIdentifier.create ~uri
+    in
+    let position = Position.yojson_of_t position in
+    let params =
+      `Assoc
+        (("position", position)
+        :: (match identifier with
+           | Some ident -> ("identifier", `String ident)
+           | None -> ("identifier", `Null))
+        :: (match contentFormat with
+           | Some fmt -> ("contentFormat", `String fmt)
+           | None -> ("contentFormat", `Null))
+        :: [ ("textDocument", text_document) ])
+    in
+    let params = Some (Jsonrpc.Structured.t_of_yojson params) in
+    let req =
+      Lsp.Client_request.UnknownRequest
+        { meth = "ocamllsp/documentation"; params }
+    in
+    Client.request client req
+
+  let print_documentation result =
+    result |> Yojson.Safe.pretty_to_string ~std:false |> print_endline
+
+  let test ~line ~character ?identifier ?contentFormat source =
+    let position = Position.create ~character ~line in
+    let request client =
+      let open Fiber.O in
+      let+ response =
+        call_documentation ~position ~identifier ~contentFormat client
+      in
+      print_documentation response
+    in
+    Helpers.test source request
+end
+
+let%expect_test "Documentation of simple type with no contentFormat and no \
+                 identifier" =
+  let source = "type tree (** This is a comment *)" in
+  let line = 0 in
+  let character = 7 in
+  Util.test ~line ~character source;
+  [%expect
+    {| { "doc": { "kind": "plaintext", "value": "This is a comment" } } |}]
+
+let%expect_test "Documentation of simple type with contentFormat set to \
+                 markdown" =
+  let source = "type tree (** This is another comment *)" in
+  let line = 0 in
+  let character = 7 in
+  let contentFormat = "markdown" in
+  Util.test ~line ~character ~contentFormat source;
+  [%expect
+    {| { "doc": { "kind": "markdown", "value": "This is another comment" } } |}]
+
+let%expect_test "Documentation of simple type with an identifier and \
+                 contentFormat" =
+  let source =
+    "{|type tree (** This is another comment *)\n\
+    \  List.iter ~f:(fun x -> x*x) [2;4]|}"
+  in
+  let line = 0 in
+  let character = 7 in
+  let identifier = "List" in
+  let contentFormat = "markdown" in
+  Util.test ~line ~character ~identifier ~contentFormat source;
+  [%expect
+    {|
+    {
+      "doc": {
+        "kind": "markdown",
+        "value": "List operations.\n\n   Some functions are flagged as not tail-recursive.  A tail-recursive\n   function uses constant stack space, while a non-tail-recursive function\n   uses stack space proportional to the length of its list argument, which\n   can be a problem with very long lists.  When the function takes several\n   list arguments, an approximate formula giving stack usage (in some\n   unspecified constant unit) is shown in parentheses.\n\n   The above considerations can usually be ignored if your lists are not\n   longer than about 10000 elements.\n\n   The labeled version of this module can be used as described in the\n   {!StdLabels} module."
+      }
+    } |}]
+
+let%expect_test "Documentation of simple type with an identifier and no \
+                 contentFormat" =
+  let source =
+    "{|type tree (** This is another comment *)\n\
+    \  List.iter ~f:(fun x -> x*x) [2;4]|}"
+  in
+  let line = 0 in
+  let character = 7 in
+  let identifier = "List" in
+  Util.test ~line ~character ~identifier source;
+  [%expect
+    {|
+    {
+      "doc": {
+        "kind": "plaintext",
+        "value": "List operations.\n\n   Some functions are flagged as not tail-recursive.  A tail-recursive\n   function uses constant stack space, while a non-tail-recursive function\n   uses stack space proportional to the length of its list argument, which\n   can be a problem with very long lists.  When the function takes several\n   list arguments, an approximate formula giving stack usage (in some\n   unspecified constant unit) is shown in parentheses.\n\n   The above considerations can usually be ignored if your lists are not\n   longer than about 10000 elements.\n\n   The labeled version of this module can be used as described in the\n   {!StdLabels} module."
+      }
+    } |}]
+
+let%expect_test "Documentation when List module is shadowed" =
+  let source =
+    "{|\n\
+     List.iter ~f:(fun x -> x*x) [2;4]\n\
+    \ module List = struct\n\
+    \  (** This is my custom list module *)\n\
+    \  let rec iter ~f = function (** This is the custom iter module *)\n\
+    \    | [] -> () (** This is when the list is empty *)\n\
+    \    | x :: xs -> f x; iter ~f xs\n\
+     end\n\
+     List.iter ~f:(fun x -> x*x) [2;4]\n\
+     |}"
+  in
+  let line = 2 in
+  let character = 6 in
+  let identifier = "List.iter" in
+  Util.test ~line ~character ~identifier source;
+  [%expect
+    {|
+  {
+    "doc": {
+      "kind": "plaintext",
+      "value": "[iter f [a1; ...; an]] applies function [f] in turn to\n   [a1; ...; an]. It is equivalent to\n   [begin f a1; f a2; ...; f an; () end]."
+    }
+  } |}]
+
+let%expect_test "Documentation when List module is shadowed" =
+  let source =
+    "{|\n\
+     List.iter ~f:(fun x -> x*x) [2;4]\n\
+     module List = struct\n\
+    \  (** This is my custom list module *)\n\
+    \  let rec iter ~f = function (** This is the custom iter module *)\n\
+    \    | [] -> () (** This is when the list is empty *)\n\
+    \    | x :: xs -> f x; iter ~f xs\n\
+     end\n\
+     Base.List.iter ~f:(fun x -> x*x) [2;4]\n\
+     |}"
+  in
+  let line = 7 in
+  let character = 12 in
+  let identifier = "Base.List.iter" in
+  Util.test ~line ~character ~identifier source;
+  [%expect
+    {|
+  { "doc": { "kind": "plaintext", "value": "Base.List.iter" } } |}]
+
+(* TODO: Open Issue in Merlin to investigate while this doesnt return documentation of the custom List module*)
+let%expect_test "Documentation when List module is shadowed" =
+  let source =
+    "{|\n\
+     List.iter ~f:(fun x -> x*x) [2;4]\n\
+     module List = struct\n\
+    \  (** This is my custom list module *)\n\
+    \  let rec iter ~f = function (** This is the custom iter module *)\n\
+    \    | [] -> () (** This is when the list is empty *)\n\
+    \    | x :: xs -> f x; iter ~f xs\n\
+     end\n\
+     Base.List.iter ~f:(fun x -> x*x) [2;4]\n\
+     |}"
+  in
+  let line = 2 in
+  let character = 9 in
+  Util.test ~line ~character source;
+  [%expect
+    {|
+  {
+    "doc": {
+      "kind": "plaintext",
+      "value": "List operations.\n\n   Some functions are flagged as not tail-recursive.  A tail-recursive\n   function uses constant stack space, while a non-tail-recursive function\n   uses stack space proportional to the length of its list argument, which\n   can be a problem with very long lists.  When the function takes several\n   list arguments, an approximate formula giving stack usage (in some\n   unspecified constant unit) is shown in parentheses.\n\n   The above considerations can usually be ignored if your lists are not\n   longer than about 10000 elements.\n\n   The labeled version of this module can be used as described in the\n   {!StdLabels} module."
+    }
+  } |}]

ocaml-lsp-server/test/e2e-new/dune

@@ -61,6 +61,7 @@
     syntax_doc_tests
     test
     type_enclosing
+    documentation
     with_pp
     with_ppx
     workspace_change_config))))

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

@@ -93,7 +93,8 @@ let%expect_test "start/stop" =
             "diagnostic_promotions": true,
             "handleHoverExtended": true,
             "handleMerlinCallCompatible": true,
-            "handleTypeEnclosing": true
+            "handleTypeEnclosing": true,
+            "handleDocumentation": true
           }
         },
         "foldingRangeProvider": true,