Jump Custom Request (#1374)

Co-authored-by: Ulysse Gérard <[email protected]>

Author: PizieDust

CHANGES.md

@@ -5,6 +5,8 @@
 
 - Make MerlinJump code action configurable (#1376)
 
+- Add custom [`ocamllsp/jump`](/ocaml-lsp-server/docs/ocamllsp/merlinJump-spec.md) request (#1374)
+
 ## Fixes
 
 - Fix fd leak in running external processes for preprocessing (#1349)

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

@@ -0,0 +1,54 @@
+# Merlin Jump Request
+
+## Description
+
+This custom request allows Merlin-type code navigation in a source buffer.
+
+## Server capability
+
+- propert name: `handleJump`
+- property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/jump`
+- params: `JumpParams`  extends [TextDocumentPositionParams](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocumentPositionParams) and is defined as follows:
+
+```js
+export interface JumpParams extends TextDocumentPositionParams
+{
+    /**
+     * The requested target of the jump, one of `fun`, `let`, `module`,
+     * `module-type`, `match`, `match-next-case`, `match-prev-case`.
+     *
+     * If omitted, all valid targets will be considered.
+     */
+    target?: string;
+}
+```
+
+## Response
+
+- result: `Jump`
+
+```js
+
+export interface TargetPosition {
+    /**
+     * The target's kind.
+     */
+    target: string;
+
+    /**
+     * The corresponding position in the request's document.
+     */
+    position: Position;
+}
+
+export interface Jump {
+    /**
+     * The list of possible targets to jump-to.
+     */
+    jumps: TargetPosition[]
+}
+```

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

@@ -8,3 +8,4 @@ module Type_enclosing = Req_type_enclosing
 module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation
 module Type_search = Req_type_search
+module Merlin_jump = Req_merlin_jump

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

@@ -10,3 +10,4 @@ module Type_enclosing = Req_type_enclosing
 module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation
 module Type_search = Req_type_search
+module Merlin_jump = Req_merlin_jump

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

@@ -0,0 +1,104 @@
+open Import
+module TextDocumentPositionParams = Lsp.Types.TextDocumentPositionParams
+
+let meth = "ocamllsp/jump"
+let capability = "handleJump", `Bool true
+
+module JumpParams = struct
+  let targets =
+    [ "fun"
+    ; "match"
+    ; "let"
+    ; "module"
+    ; "module-type"
+    ; "match-next-case"
+    ; "match-prev-case"
+    ]
+  ;;
+
+  type t =
+    { textDocument : TextDocumentIdentifier.t
+    ; position : Position.t
+    ; target : string option
+    }
+
+  let t_of_yojson json =
+    let open Yojson.Safe.Util in
+    { textDocument = json |> member "textDocument" |> TextDocumentIdentifier.t_of_yojson
+    ; position = json |> member "position" |> Position.t_of_yojson
+    ; target = json |> member "target" |> to_string_option
+    }
+  ;;
+
+  let yojson_of_t { textDocument; position; target } =
+    let target =
+      Option.value_map target ~default:[] ~f:(fun v -> [ "target", `String v ])
+    in
+    `Assoc
+      (("textDocument", TextDocumentIdentifier.yojson_of_t textDocument)
+       :: ("position", Position.yojson_of_t position)
+       :: target)
+  ;;
+end
+
+module Jump = struct
+  type t = (string * Position.t) list
+
+  let yojson_of_t (lst : t) : Yojson.Safe.t =
+    let jumps =
+      List.map
+        ~f:(fun (target, position) ->
+          `Assoc [ "target", `String target; "position", Position.yojson_of_t position ])
+        lst
+    in
+    `Assoc [ "jumps", `List jumps ]
+  ;;
+end
+
+type t = Jump.t
+
+module Request_params = struct
+  type t = JumpParams.t
+
+  let yojson_of_t t = JumpParams.yojson_of_t t
+
+  let create ~uri ~position ~target =
+    { JumpParams.textDocument = TextDocumentIdentifier.create ~uri; position; target }
+  ;;
+end
+
+let dispatch ~merlin ~position ~target =
+  Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+    let pposition = Position.logical position in
+    let query = Query_protocol.Jump (target, pposition) in
+    Query_commands.dispatch pipeline query)
+;;
+
+let on_request ~params state =
+  let open Fiber.O in
+  Fiber.of_thunk (fun () ->
+    let params = (Option.value ~default:(`Assoc []) params :> Yojson.Safe.t) in
+    let params = JumpParams.t_of_yojson params in
+    let uri = params.textDocument.uri in
+    let position = params.position in
+    let doc = Document_store.get state.State.store uri in
+    match Document.kind doc with
+    | `Other -> Fiber.return `Null
+    | `Merlin merlin ->
+      let targets =
+        match params.target with
+        | None -> JumpParams.targets
+        | Some target -> [ target ]
+      in
+      let+ results =
+        Fiber.parallel_map targets ~f:(fun target ->
+          dispatch ~merlin ~position ~target
+          |> Fiber.map ~f:(function
+            | `Error _ -> None
+            | `Found pos ->
+              (match Position.of_lexical_position pos with
+               | None -> None
+               | Some position -> Some (target, position))))
+      in
+      Jump.yojson_of_t (List.filter_map results ~f:Fun.id))
+;;

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

@@ -0,0 +1,14 @@
+open Import
+
+module Request_params : sig
+  type t
+
+  val yojson_of_t : t -> Json.t
+  val create : uri:DocumentUri.t -> position:Position.t -> target:string option -> t
+end
+
+type t
+
+val meth : string
+val capability : string * [> `Bool of bool ]
+val on_request : params:Jsonrpc.Structured.t option -> State.t -> Json.t Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -97,6 +97,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : InitializeRes
               ; Req_get_documentation.capability
               ; Req_construct.capability
               ; Req_type_search.capability
+              ; Req_merlin_jump.capability
               ] )
         ]
     in
@@ -526,6 +527,7 @@ let 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
+       ; Req_merlin_jump.meth, Req_merlin_jump.on_request
        ; Req_wrapping_ast_node.meth, Req_wrapping_ast_node.on_request
        ; Req_type_search.meth, Req_type_search.on_request
        ; Req_construct.meth, Req_construct.on_request

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

@@ -63,6 +63,7 @@
     test
     type_enclosing
     documentation
+    merlin_jump
     type_search
     with_pp
     with_ppx

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

@@ -0,0 +1,138 @@
+open Test.Import
+module Req = Ocaml_lsp_server.Custom_request.Merlin_jump
+
+module Util = struct
+  let call_jump position ?target client =
+    let uri = DocumentUri.of_path "test.ml" in
+    let params =
+      Req.Request_params.create ~uri ~position ~target
+      |> Req.Request_params.yojson_of_t
+      |> Jsonrpc.Structured.t_of_yojson
+      |> Option.some
+    in
+    let req = Lsp.Client_request.UnknownRequest { meth = "ocamllsp/jump"; params } in
+    Client.request client req
+  ;;
+
+  let test ~line ~character ~source ?target () =
+    let position = Position.create ~character ~line in
+    let request client =
+      let open Fiber.O in
+      let+ response = call_jump position client ?target in
+      Test.print_result response
+    in
+    Helpers.test source request
+  ;;
+end
+
+let%expect_test "Get all jumps including the next match case" =
+  let source =
+    {|
+let find_vowel x =
+match x with
+| 'A' -> true
+| 'E' -> true
+| 'I' -> true
+| 'O' -> true
+| 'U' -> true
+| _ -> false
+|}
+  in
+  let line = 3 in
+  let character = 2 in
+  Util.test ~line ~character ~source ();
+  [%expect
+    {|
+  {
+    "jumps": [
+      { "target": "fun", "position": { "character": 0, "line": 1 } },
+      { "target": "match", "position": { "character": 0, "line": 2 } },
+      { "target": "let", "position": { "character": 0, "line": 1 } },
+      {
+        "target": "match-next-case",
+        "position": { "character": 2, "line": 4 }
+      }
+    ]
+  } |}]
+;;
+
+let%expect_test "Get location of the next match case" =
+  let source =
+    {|
+let find_vowel x =
+match x with
+| 'A' -> true
+| 'E' -> true
+| 'I' -> true
+| 'O' -> true
+| 'U' -> true
+| _ -> false
+|}
+  in
+  let line = 3 in
+  let character = 2 in
+  Util.test ~line ~character ~source ~target:"match-next-case" ();
+  [%expect
+    {|
+    {
+      "jumps": [
+        {
+          "target": "match-next-case",
+          "position": { "character": 2, "line": 4 }
+        }
+      ]
+    }
+    |}]
+;;
+
+let%expect_test "Get location of a the module" =
+  let source =
+    {|type a = Foo | Bar
+
+module A = struct
+  let f () = 10
+  let g = Bar
+  let h x = x
+
+  module B = struct
+    type b = Baz
+
+    let x = (Baz, 10)
+    let y = (Bar, Foo)
+  end
+
+  type t = { a : string; b : float }
+
+  let z = { a = "Hello"; b = 1.0 }
+end|}
+  in
+  let line = 10 in
+  let character = 3 in
+  Util.test ~line ~character ~source ();
+  [%expect
+    {|
+  {
+    "jumps": [
+      { "target": "module", "position": { "character": 2, "line": 7 } }
+    ]
+  } |}]
+;;
+
+let%expect_test "Same line should output no locations" =
+  let source = {|let x = 5 |} in
+  let line = 1 in
+  let character = 5 in
+  Util.test ~line ~character ~source ();
+  [%expect {| { "jumps": [] } |}]
+;;
+
+let%expect_test "Ask for a non-existing target" =
+  let source = {|
+let find_vowel x = ()
+|} in
+  let line = 1 in
+  let character = 2 in
+  Util.test ~line ~character ~source ~target:"notatarget" ();
+  [%expect
+    {| { "jumps": [] } |}]
+;;

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

@@ -94,7 +94,8 @@ let%expect_test "start/stop" =
             "handleTypeEnclosing": true,
             "handleGetDocumentation": true,
             "handleConstruct": true,
-            "handleTypeSearch": true
+            "handleTypeSearch": true,
+            "handleJump": true
           }
         },
         "foldingRangeProvider": true,