Type enclosing query

CHANGES.md

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

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

@@ -0,0 +1,59 @@
+# Type Enclosing Request
+
+## Description
+
+Merlin has a concept of `type enclosing` that gets the type of ident under the
+cursor. It will highlight the ident and display its type. You can climb the
+typed-tree and display the type of bigger expressions surrounding the cursor. In
+order to keep the request stateless, the manipulation related to growing or
+shrinking enclosings is delegated to the client. This request allows to request
+type enclosing under the cursor and then its surrounding enclosings.
+
+## Client capability
+
+There is no client capability relative to this request.
+
+## Server capability
+
+- property name: `handleTypeEnclosing`
+- property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/typeEnclosing`
+- params:
+
+  ```json
+  {
+    "uri": TextDocumentIdentifier,
+    "at": (Position | Range),
+    "index": uinteger,
+    "verbosity?": uinteger,
+  }
+  ```
+
+  - `index` can be used to print only one type information. This is useful to query
+    the types lazily: normally, Merlin would return the signature of all enclosing
+    modules, which can be very expensive.
+  - `verbosity` determines the number of expansions of aliases in answers.
+  - `at` :
+    - if a `Position` is given, it will returns all enclosing around the position
+    - if a `Range` is given, only enclosings that contain the range
+    `[range.start; range.end[` will be included in the answer
+
+
+## Response
+
+```json
+{
+  "enclosings": Range[],
+  "index": uinteger,
+  "type": string
+}
+```
+
+- `enclosings`: The surrounding enclosings
+- `index` The index of the provided type result: the index corresponds to a
+  zero-indexed enclosing in the `enclosings`' array. It is the same value as the
+  one provided in this request's `TypeEnclosingParams`
+- `type`: The type of the enclosing `enclosings[index]` as a raw string

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

@@ -0,0 +1,182 @@
+open Import
+module TextDocumentPositionParams = Lsp.Types.TextDocumentPositionParams
+
+let capability = ("handleTypeEnclosing", `Bool true)
+
+let meth = "ocamllsp/typeEnclosing"
+
+module Request_params = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; at : [ `Range of Range.t | `Position of Position.t ]
+    ; index : int
+    ; verbosity : int
+    }
+
+  let yojson_of_at = function
+    | `Range r -> Range.yojson_of_t r
+    | `Position p -> Position.yojson_of_t p
+
+  let yojson_of_t { text_document; index; at; verbosity } =
+    match TextDocumentIdentifier.yojson_of_t text_document with
+    | `Assoc assoc ->
+      let index = ("index", `Int index) in
+      let range_end = ("at", yojson_of_at at) in
+      let verbosity = ("verbosity", `Int verbosity) in
+      `Assoc (index :: range_end :: verbosity :: assoc)
+    | _ -> (* unreachable  *) assert false
+
+  let create ?(verbosity = 0) ~text_document ~at ~index () =
+    { text_document; index; at; verbosity }
+
+  let json_error json =
+    Json.error "invalid Req_type_enclosing.Request_params" json
+
+  let index_of_yojson json params =
+    match List.assoc_opt "index" params with
+    | Some (`Int index) -> index
+    | _ ->
+      (* If the parameter is incorrectly formatted or missing, we refuse to build
+         the parameter, [index] is mandatory. *)
+      json_error json
+
+  let verbosity_of_yojson params =
+    match List.assoc_opt "verbosity" params with
+    | Some (`Int verbosity) -> verbosity
+    | _ ->
+      (* If the parameter is incorrectly formatted or missing, it is assumed that
+         the we ask for a verbosity level set to 0. *)
+      0
+
+  let at_of_yojson json params =
+    match List.assoc_opt "at" params with
+    | Some at -> (
+      try `Position (Position.t_of_yojson at)
+      with _ -> `Range (Range.t_of_yojson at))
+    | _ ->
+      (* If the parameter is incorrectly formatted or missing, we refuse to build
+         the parameter, [at] is mandatory. *)
+      json_error json
+
+  let t_of_yojson = function
+    | `Assoc params as json ->
+      let verbosity = verbosity_of_yojson params in
+      let at = at_of_yojson json params in
+      let index = index_of_yojson json params in
+      let text_document = TextDocumentIdentifier.t_of_yojson json in
+      { index; at; verbosity; text_document }
+    | json -> json_error json
+end
+
+type t =
+  { index : int
+  ; type_ : string
+  ; enclosings : Range.t list
+  }
+
+let yojson_of_t { index; type_; enclosings } =
+  `Assoc
+    [ ("index", `Int index)
+    ; ("enclosings", `List (List.map ~f:Range.yojson_of_t enclosings))
+    ; ("type", `String type_)
+    ]
+
+let config_with_given_verbosity config verbosity =
+  let open Mconfig in
+  { config with query = { config.query with verbosity } }
+
+let with_pipeline state uri verbosity with_pipeline =
+  let doc = Document_store.get state.State.store uri in
+  match Document.kind doc with
+  | `Other -> Fiber.return `Null
+  | `Merlin merlin ->
+    let open Fiber.O in
+    let* config = Document.Merlin.mconfig merlin in
+    Document.Merlin.with_configurable_pipeline_exn
+      ~config:(config_with_given_verbosity config verbosity)
+      merlin
+      with_pipeline
+
+let make_enclosing_command position index =
+  Query_protocol.Type_enclosing (None, position, Some index)
+
+let get_first_enclosing_index range_end enclosings =
+  List.find_mapi enclosings ~f:(fun i (loc, _, _) ->
+      let range = Range.of_loc loc in
+      match Position.compare range_end range.end_ with
+      | Ordering.Lt | Ordering.Eq -> Some i
+      | Ordering.Gt -> None)
+
+let dispatch_command pipeline command first_index index =
+  let rec aux i acc = function
+    | (_, `String typ, _) :: _ as enclosings when i = index ->
+      Some
+        ( typ
+        , List.map
+            ~f:(fun (loc, _, _) -> Range.of_loc loc)
+            (List.rev_append acc enclosings) )
+    | curr :: enclosings -> aux (succ i) (curr :: acc) enclosings
+    | [] -> None
+  in
+  let result =
+    List.drop (Query_commands.dispatch pipeline command) first_index
+  in
+  aux 0 [] result
+
+let dispatch_with_range_end pipeline position index range_end =
+  (* merlin's `type-enclosing` command takes a position and returns a list of
+     increasing enclosures around that position. If it is given the [index]
+     parameter, it annotates the corresponding enclosing with its type.
+
+     As the request would like to allow the target of an interval, we want to
+     truncate the list of enclosures that include the interval. Something merlin
+     cannot do.
+
+     We use a little hack where we use the `type-enclosing` command (with a
+     negative index, so as not to make unnecessary computations) to calculate
+     the enclosings around the given position. Then, we look for the index
+     corresponding to the first enclosing included in the range which will act
+     as an offset to calculate the real index, relative to the range *)
+  let dummy_command = make_enclosing_command position (-1) in
+  let enclosings = Query_commands.dispatch pipeline dummy_command in
+  Option.bind
+    (get_first_enclosing_index range_end enclosings)
+    ~f:(fun first_index ->
+      let real_index = first_index + index in
+      let command = make_enclosing_command position real_index in
+      dispatch_command pipeline command first_index index)
+
+let dispatch_without_range_end pipeline position index =
+  let command = make_enclosing_command position index in
+  dispatch_command pipeline command 0 index
+
+let dispatch_type_enclosing position index range_end pipeline =
+  let position = Position.logical position in
+  let result =
+    match range_end with
+    | None -> dispatch_without_range_end pipeline position index
+    | Some range_end ->
+      dispatch_with_range_end pipeline position index range_end
+  in
+  let type_, enclosings =
+    match result with
+    | None -> ("<no information>", [])
+    | Some (typ, enclosings) -> (typ, enclosings)
+  in
+  yojson_of_t { index; type_; enclosings }
+
+let on_request ~params state =
+  Fiber.of_thunk (fun () ->
+      let params = (Option.value ~default:(`Assoc []) params :> Json.t) in
+      let Request_params.{ index; verbosity; text_document; at } =
+        Request_params.t_of_yojson params
+      in
+      let position, range_end =
+        match at with
+        | `Position p -> (p, None)
+        | `Range r -> (r.start, Some r.end_)
+      in
+      let uri = text_document.uri in
+      let verbosity = Mconfig.Verbosity.Lvl verbosity in
+      with_pipeline state uri verbosity
+      @@ dispatch_type_enclosing position index range_end)

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

@@ -0,0 +1,23 @@
+open Import
+
+module Request_params : sig
+  type t
+
+  val create :
+       ?verbosity:int
+    -> text_document:Lsp.Types.TextDocumentIdentifier.t
+    -> at:[ `Position of Position.t | `Range of Range.t ]
+    -> index:int
+    -> unit
+    -> t
+
+  val yojson_of_t : t -> Json.t
+end
+
+type t
+
+val capability : string * Json.t
+
+val meth : string
+
+val on_request : params:Jsonrpc.Structured.t option -> State.t -> Json.t Fiber.t

ocaml-lsp-server/src/import.ml

@@ -28,6 +28,8 @@ include struct
 
     let findi xs ~f = List.findi xs ~f
 
+    let find_mapi xs ~f = List.find_mapi xs ~f
+
     let sub xs ~pos ~len = List.sub xs ~pos ~len
 
     let hd_exn t = List.hd_exn t
@@ -39,6 +41,8 @@ include struct
     let filter t ~f = List.filter t ~f
 
     let tl t = List.tl t
+
+    let drop xs i = List.drop xs i
   end
 
   module Map = Map

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -99,6 +99,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
               ; Dune.view_promotion_capability
               ; Req_hover_extended.capability
               ; Req_merlin_call_compatible.capability
+              ; Req_type_enclosing.capability
               ] )
         ]
     in
@@ -521,6 +522,7 @@ let on_request :
       ; (Req_infer_intf.meth, Req_infer_intf.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_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/dune

@@ -60,6 +60,7 @@
     start_stop
     syntax_doc_tests
     test
+    type_enclosing
     with_pp
     with_ppx
     workspace_change_config))))

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

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