Merge 7bdedcf into d41d8dd

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,51 @@
+# 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.
+Since _LSP_ is stateless, the manipulation related to growing or shrinking
+enclosings is delayed to the client. This request allows to request type
+enclosing under the cursor with a support of parent 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
+  {
+    "textDocument": TextDocumentIdentifier,
+    "position": Position,
+    "workDoneToken?": ProgressToken,
+    "index": uinteger,
+    "verbosity": uinteger,
+    "rangeEnd?": Position
+  }
+  ```
+
+## Response
+
+```json
+{
+  "enclosings": ({"type": string} & 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,223 @@
+open Import
+
+let capability = ("handleTypeEnclosing", `Bool true)
+
+let meth = "ocamllsp/typeEnclosing"
+
+type params =
+  { text_document_position : Lsp.Types.TextDocumentPositionParams.t
+  ; work_done_progress : Lsp.Types.WorkDoneProgressParams.t
+  ; index : int
+  ; range_end : Position.t option
+  ; verbosity : int
+  }
+
+let expected_params =
+  `Assoc
+    [ ("index", `String "uinteger")
+    ; ("rangeEnd?", `String "<Position>")
+    ; ("verbosity?", `String "uinteger")
+    ; ("position", `String "<Position>")
+    ; ("textDocument", `String "<TextDocumentIdentifier>")
+    ; ("workDoneToken?", `String "<ProgressToken>")
+    ]
+
+let index_of_yojson params =
+  match List.assoc_opt "index" params with
+  | Some (`Int index) -> Some index
+  | _ ->
+    (* If the parameter is incorrectly formatted or missing, we refuse to build
+       the parameter, [index] is mandatory. *)
+    None
+
+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 range_end_of_yojson params =
+  match List.assoc_opt "rangeEnd" params with
+  | Some range_end -> (
+    try Some (Position.t_of_yojson range_end) with _ -> None)
+  | _ ->
+    (* If the parameter is incorrectly formatted or missing, it is assumed that
+       the we do not provide rangeEnd parameter. *)
+    None
+
+let raise_invalid_params ?data ~message () =
+  let open Jsonrpc.Response.Error in
+  raise @@ make ?data ~code:Code.InvalidParams ~message ()
+
+let of_yojson = function
+  | `Assoc params as full_params ->
+    let verbosity = verbosity_of_yojson params in
+    let range_end = range_end_of_yojson params in
+    let open Option.O in
+    let* index = index_of_yojson params in
+    let text_document_position =
+      Lsp.Types.TextDocumentPositionParams.t_of_yojson full_params
+    in
+    let work_done_progress =
+      Lsp.Types.WorkDoneProgressParams.t_of_yojson full_params
+    in
+    Some
+      { index
+      ; range_end
+      ; verbosity
+      ; text_document_position
+      ; work_done_progress
+      }
+  | _ -> None
+
+let of_yojson_exn = function
+  | None -> raise_invalid_params ~message:"Expected params but received none" ()
+  | Some params -> (
+    match of_yojson params with
+    | Some params -> params
+    | None ->
+      let data =
+        `Assoc
+          [ ("expectedParams", expected_params)
+          ; ("receivedParams", (params :> Json.t))
+          ]
+      in
+      raise_invalid_params ~data ~message:"Unexpected params format" ())
+
+let get_position pipeline text_document_position =
+  let pos =
+    text_document_position.Lsp.Types.TextDocumentPositionParams.position
+  in
+  let pos = Position.logical pos in
+  Mpipeline.get_lexing_pos pipeline pos
+
+let parse_identifier (config, source) pos =
+  (* FIXME: in latest Merlin version the function is located in
+     Merlin_analysis. *)
+  let path = Mreader.reconstruct_identifier config source pos in
+  Merlin_kernel.Mreader_lexer.identifier_suffix path
+
+let reconstruct_identifier pipeline pos =
+  let config = Mpipeline.input_config pipeline in
+  let source = Mpipeline.raw_source pipeline in
+  let path = parse_identifier (config, source) pos in
+  let reify dot =
+    if
+      String.equal "" dot
+      || (dot.[0] >= 'a' && dot.[0] <= 'z')
+      || (dot.[0] >= 'A' && dot.[0] <= 'Z')
+    then dot
+    else "( " ^ dot ^ ")"
+  in
+  match path with
+  | [] -> []
+  | base :: tail ->
+    let f { Loc.txt = base; loc = bl } { Loc.txt = dot; loc = dl } =
+      let loc = Merlin_parsing.Location_aux.union bl dl in
+      let txt = base ^ "." ^ reify dot in
+      Merlin_parsing.Location.mkloc txt loc
+    in
+    [ List.fold_left tail ~init:base ~f ]
+
+let overlap_with_range_end range = function
+  | None -> true
+  | Some position ->
+    let lend = range.Range.end_ in
+    if lend.line = position.Position.line then
+      lend.character > position.character
+    else lend.line > position.line
+
+let collect_all_results verbosity small_enclosing range_end result =
+  let ppf = Format.str_formatter in
+  List.filter_map
+    ~f:(fun (loc, text, _tail) ->
+      let range = Range.of_loc loc in
+      let ret x = Some (range, x) in
+      let open Merlin_analysis in
+      match text with
+      | _ when not (overlap_with_range_end range range_end) -> None
+      | Type_enclosing.String str -> ret str
+      | Type_enclosing.Type (env, t) ->
+        Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
+            Type_utils.print_type_with_decl ~verbosity env ppf t);
+        ret (Format.flush_str_formatter ())
+      | Type_enclosing.Type_decl (env, id, t) ->
+        Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
+            Type_utils.Printtyp.type_declaration env id ppf t);
+        ret (Format.flush_str_formatter ())
+      | Type_enclosing.Modtype (env, m) ->
+        Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
+            Type_utils.Printtyp.modtype env ppf m);
+        ret (Format.flush_str_formatter ()))
+    (small_enclosing @ result)
+  |> Merlin_utils.Std.List.merge_cons
+       ~f:(fun (a_range, a_typ) (b_range, b_typ) ->
+         if Range.compare a_range b_range = Eq && String.equal a_typ b_typ then
+           Some (b_range, b_typ)
+         else None)
+
+let type_enclosing text_document_position verbosity range_end pipeline =
+  let typer = Mpipeline.typer_result pipeline in
+  let pos = get_position pipeline text_document_position in
+  let structures =
+    Mbrowse.(enclosing pos [ of_typedtree @@ Mtyper.get_typedtree typer ])
+  in
+  let path =
+    match structures with
+    | [] -> []
+    | browse -> Merlin_analysis.Browse_misc.annotate_tail_calls browse
+  in
+  let result = Merlin_analysis.Type_enclosing.from_nodes ~path in
+  let expression = reconstruct_identifier pipeline pos in
+  let small_enclosing =
+    Merlin_analysis.Type_enclosing.from_reconstructed
+      ~nodes:structures
+      ~cursor:pos
+      ~verbosity
+      expression
+  in
+  collect_all_results verbosity small_enclosing range_end result
+
+let render_result index result =
+  let current_typ =
+    match index |> List.nth result with
+    | None -> "<no information>"
+    | Some (_, typ) -> typ
+  in
+  let enclosings =
+    List.map
+      ~f:(fun (loc, typ) ->
+        `Assoc
+          [ ("start", Position.yojson_of_t loc.Range.start)
+          ; ("end_", Position.yojson_of_t loc.Range.end_)
+          ; ("type", `String typ)
+          ])
+      result
+  in
+  `Assoc
+    [ ("index", `Int index)
+    ; ("enclosings", `List enclosings)
+    ; ("type", `String current_typ)
+    ]
+
+let with_pipeline state uri f =
+  let doc = Document_store.get state.State.store uri in
+  match Document.kind doc with
+  | `Other -> Fiber.return []
+  | `Merlin merlin -> Document.Merlin.with_pipeline_exn merlin f
+
+let on_request ~params state =
+  Fiber.of_thunk (fun () ->
+      let open Fiber.O in
+      let { index; verbosity; text_document_position; range_end; _ } =
+        of_yojson_exn params
+      in
+      let uri = text_document_position.textDocument.uri in
+      let verbosity = Mconfig.Verbosity.Lvl verbosity in
+      let+ result =
+        with_pipeline state uri
+        @@ type_enclosing text_document_position verbosity range_end
+      in
+      render_result index result)

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

@@ -0,0 +1,7 @@
+open Import
+
+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/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,