More control on typed holes (for navigation) (ocaml#1516)

* Introduce a new custom request `ocamllsp/jumpTypedHole`

* Test the custom request

* Add CHANGE entry

* Add more tests related to range

* Add specification

* Simplify request description

* Refactor typed-holes usage in a dedicated module

* Rename request name

* Rephrase documentation

* Rename `name` to `pipeline_name`

Author: xvw

CHANGES.md

@@ -3,6 +3,7 @@
 ## Features
 
 - Make `inlay-hint` for function parameters configurable (#1515)
+- Add custom `ocamllsp/jumpToTypedHole` to navigate through typed holes (#1516)
 
 ## Fixes
 

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

@@ -0,0 +1,57 @@
+# Jump To Typed Holes Requet
+
+### Description
+
+Returns the next or previous typed hole at a given position (included
+in a range or not).
+
+
+### Why this custom request needed
+
+Reduces the need for editor-side logic and works well with the
+expression construct command. For example, constructing a value of
+type `int option` constructs the following expression:
+`Some _`, coupled with typed hole navigation, you can move the cursor
+directly over the generated hole.
+
+
+### A note on stability: 
+
+> OCaml-LSP does not guarantee stability for this custom request,
+> meaning the core contributors may change or remove this custom
+> request, as they see necessary.
+
+## Client capability
+
+N/A
+
+## Server capability
+
+- property name: `handleJumpToTypedHole`
+- property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/jumpToTypedHole`
+- params:
+
+```json
+{
+  "uri": TextDocumentIdentifier,
+  "position": Position,
+  "direction": <"next"|"prev">,
+  "range?": Range
+}
+```
+
+If a `range` is given, it will only select holes present in the given
+range.
+
+## Response
+
+```json
+Range | null
+```
+
+Returns the next or previous typed hole at a given position. An
+optional range can be used to restrict the search.

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

@@ -4,6 +4,7 @@ module Infer_intf = Req_infer_intf
 module Merlin_call_compatible = Req_merlin_call_compatible
 module Switch_impl_intf = Req_switch_impl_intf
 module Typed_holes = Req_typed_holes
+module Jump_to_typed_hole = Req_jump_to_typed_hole
 module Type_enclosing = Req_type_enclosing
 module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation

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

@@ -6,6 +6,7 @@ module Infer_intf = Req_infer_intf
 module Merlin_call_compatible = Req_merlin_call_compatible
 module Switch_impl_intf = Req_switch_impl_intf
 module Typed_holes = Req_typed_holes
+module Jump_to_typed_hole = Req_jump_to_typed_hole
 module Type_enclosing = Req_type_enclosing
 module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation

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

@@ -0,0 +1,89 @@
+open Import
+
+let capability = "handleJumpToTypedHole", `Bool true
+let meth = "ocamllsp/jumpToTypedHole"
+
+module Request_params = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; position : Position.t
+    ; range : Range.t option
+    ; direction : [ `Next | `Prev ]
+    }
+
+  let create ?(direction = `Next) ?range ~text_document ~position () =
+    { text_document; position; direction; range }
+  ;;
+
+  let yojson_of_direction = function
+    | `Next -> `String "next"
+    | `Prev -> `String "prev"
+  ;;
+
+  let yojson_of_t { text_document; position; direction; range } =
+    match TextDocumentIdentifier.yojson_of_t text_document with
+    | `Assoc assoc ->
+      let position = "position", Position.yojson_of_t position in
+      let range =
+        ( "range"
+        , match range with
+          | None -> `Null
+          | Some r -> Range.yojson_of_t r )
+      in
+      let direction = "direction", yojson_of_direction direction in
+      `Assoc (direction :: position :: range :: assoc)
+    | _ -> (* unreachable *) assert false
+  ;;
+
+  let direction_of_yojson json =
+    let open Yojson.Safe.Util in
+    let dir = json |> member "direction" |> to_string in
+    match String.lowercase_ascii dir with
+    | "prev" -> `Prev
+    | _ -> `Next
+  ;;
+
+  let t_of_yojson json =
+    let open Yojson.Safe.Util in
+    let text_document = TextDocumentIdentifier.t_of_yojson json in
+    let position = json |> member "position" |> Position.t_of_yojson in
+    let direction = direction_of_yojson json in
+    let range = json |> member "range" |> to_option Range.t_of_yojson in
+    { text_document; position; direction; range }
+  ;;
+end
+
+type t = Range.t option
+
+let t_of_yojson opt =
+  let open Yojson.Safe.Util in
+  to_option Range.t_of_yojson opt
+;;
+
+let yojson_of_t = function
+  | None -> `Null
+  | Some range -> Range.yojson_of_t range
+;;
+
+let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) =
+  Fiber.of_thunk (fun () ->
+    let params = (Option.value ~default:(`Assoc []) params :> Json.t) in
+    let Request_params.{ text_document = { uri }; position; direction; range } =
+      Request_params.t_of_yojson params
+    in
+    match Document_store.get_opt state.store uri with
+    | Some doc ->
+      let open Fiber.O in
+      let merlin = Document.merlin_exn doc in
+      let+ holes = Typed_hole.all ~pipeline_name:"jump-to-typed-hole" merlin in
+      holes |> Typed_hole.find ~position ~range ~direction |> yojson_of_t
+    | None ->
+      Jsonrpc.Response.Error.raise
+      @@ Jsonrpc.Response.Error.make
+           ~code:Jsonrpc.Response.Error.Code.InvalidParams
+           ~message:
+             (Printf.sprintf
+                "Document %s wasn't found in the document store"
+                (Uri.to_string uri))
+           ())
+;;

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

@@ -0,0 +1,22 @@
+open Import
+
+module Request_params : sig
+  type t
+
+  val create
+    :  ?direction:[ `Next | `Prev ]
+    -> ?range:Range.t
+    -> text_document:Lsp.Types.TextDocumentIdentifier.t
+    -> position:Position.t
+    -> unit
+    -> t
+
+  val yojson_of_t : t -> Json.t
+end
+
+type t
+
+val t_of_yojson : Json.t -> 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/custom_requests/req_typed_holes.ml

@@ -46,9 +46,7 @@ end
 
 type t = Range.t list
 
-let yojson_of_t holes =
-  Json.yojson_of_list (fun (loc, _type) -> loc |> Range.of_loc |> Range.yojson_of_t) holes
-;;
+let yojson_of_t holes = Json.yojson_of_list Range.yojson_of_t holes
 
 let t_of_yojson list =
   let open Yojson.Safe.Util in
@@ -72,7 +70,7 @@ let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) =
            ()
     | Some doc ->
       let+ holes =
-        Document.Merlin.dispatch_exn ~name:"typed-holes" (Document.merlin_exn doc) Holes
+        Typed_hole.all ~pipeline_name:"typed-holes" (Document.merlin_exn doc)
       in
       yojson_of_t holes)
 ;;

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -89,6 +89,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : InitializeRes
               ; Req_switch_impl_intf.capability
               ; Req_infer_intf.capability
               ; Req_typed_holes.capability
+              ; Req_jump_to_typed_hole.capability
               ; Req_wrapping_ast_node.capability
               ; Dune.view_promotion_capability
               ; Req_hover_extended.capability
@@ -497,6 +498,7 @@ let on_request
                Fiber.return (Req_switch_impl_intf.on_request ~params state)) )
        ; Req_infer_intf.meth, Req_infer_intf.on_request
        ; Req_typed_holes.meth, Req_typed_holes.on_request
+       ; Req_jump_to_typed_hole.meth, Req_jump_to_typed_hole.on_request
        ; Req_merlin_call_compatible.meth, Req_merlin_call_compatible.on_request
        ; Req_type_enclosing.meth, Req_type_enclosing.on_request
        ; Req_get_documentation.meth, Req_get_documentation.on_request

ocaml-lsp-server/src/typed_hole.ml

@@ -0,0 +1,47 @@
+open Import
+
+let in_range range holes =
+  match range with
+  | None -> holes
+  | Some range -> List.filter ~f:(Range.contains range) holes
+;;
+
+let find_prev ~range ~position holes =
+  let holes = in_range range holes in
+  Base.List.fold_until
+    ~init:None
+    ~f:(fun prev hole ->
+      match Position.compare hole.end_ position with
+      | Lt -> Continue (Some hole)
+      | Gt | Eq -> Stop prev)
+    ~finish:Fun.id
+    holes
+  |> function
+  | None -> Base.List.last holes
+  | hole -> hole
+;;
+
+let find_next ~range ~position holes =
+  let holes = in_range range holes in
+  List.find
+    ~f:(fun hole ->
+      match Position.compare hole.start position with
+      | Gt -> true
+      | Lt | Eq -> false)
+    holes
+  |> function
+  | None -> Base.List.hd holes
+  | hole -> hole
+;;
+
+let find ~range ~position ~direction holes =
+  match direction with
+  | `Prev -> find_prev ~range ~position holes
+  | `Next -> find_next ~range ~position holes
+;;
+
+let all ?(pipeline_name = "typed-holes") merlin =
+  Holes
+  |> Document.Merlin.dispatch_exn ~name:pipeline_name merlin
+  |> Fiber.map ~f:(List.map ~f:(fun (loc, _ty) -> Range.of_loc loc))
+;;

ocaml-lsp-server/src/typed_hole.mli

@@ -0,0 +1,8 @@
+val find
+  :  range:Range.t option
+  -> position:Position.t
+  -> direction:[< `Next | `Prev ]
+  -> Range.t list
+  -> Range.t option
+
+val all : ?pipeline_name:string -> Document.Merlin.t -> Range.t list Fiber.t