Merlins Jump in Ocaml-LSP

CHANGES.md

@@ -12,6 +12,8 @@
 
 - Add support for OCaml 5.2 (#1233)
 
+- Add a code-action for syntactic and semantic movement shortcuts based on Merlin's Jump command (#1364)
+
 ## Fixes
 
 - Kill unnecessary ocamlformat processes with sigterm rather than sigint or

ocaml-lsp-server/src/code_actions.ml

@@ -118,13 +118,22 @@ let compute server (params : CodeActionParams.t) =
       in
       Action_open_related.for_uri capabilities doc
     in
+    let* merlin_jumps =
+      let capabilities =
+        let open Option.O in
+        let* window = (State.client_capabilities state).window in
+        window.showDocument
+      in
+      Action_jump.code_actions doc params capabilities
+    in
     (match Document.syntax doc with
      | Ocamllex | Menhir | Cram | Dune ->
        Fiber.return (Reply.now (actions (dune_actions @ open_related)), state)
      | Ocaml | Reason ->
        let reply () =
          let+ code_action_results = compute_ocaml_code_actions params state doc in
-         List.concat [ code_action_results; dune_actions; open_related ] |> actions
+         List.concat [ code_action_results; dune_actions; open_related; merlin_jumps ]
+         |> actions
        in
        let later f =
          Fiber.return

ocaml-lsp-server/src/code_actions/action_jump.ml

@@ -0,0 +1,83 @@
+open Import
+open Fiber.O
+open Stdune
+
+let command_name = "ocamllsp/merlin-jump-to-target"
+
+let targets =
+  [ "fun"; "match"; "let"; "module"; "module-type"; "match-next-case"; "match-prev-case" ]
+;;
+
+let available (capabilities : ShowDocumentClientCapabilities.t option) =
+  match capabilities with
+  | Some { support } -> support
+  | None -> false
+;;
+
+let error message =
+  Jsonrpc.Response.Error.raise
+  @@ Jsonrpc.Response.Error.make
+       ~code:Jsonrpc.Response.Error.Code.InvalidParams
+       ~message
+       ()
+;;
+
+let command_run server (params : ExecuteCommandParams.t) =
+  let uri, range =
+    match params.arguments with
+    | Some [ json_uri; json_range ] ->
+      let uri = DocumentUri.t_of_yojson json_uri in
+      let range = Range.t_of_yojson json_range in
+      uri, range
+    | None | Some _ -> error "takes a URI and a range as input"
+  in
+  let+ { ShowDocumentResult.success } =
+    let req = ShowDocumentParams.create ~uri ~selection:range ~takeFocus:true () in
+    Server.request server (Server_request.ShowDocumentRequest req)
+  in
+  if not success
+  then (
+    let uri = Uri.to_string uri in
+    Format.eprintf "failed to open %s@." uri);
+  `Null
+;;
+
+(* Dispatch the jump request to Merlin and get the result *)
+let process_jump_request ~merlin ~position ~target =
+  let+ results =
+    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)
+  in
+  match results with
+  | `Error _ -> None
+  | `Found pos -> Some pos
+;;
+
+let code_actions
+  (doc : Document.t)
+  (params : CodeActionParams.t)
+  (capabilities : ShowDocumentClientCapabilities.t option)
+  =
+  match Document.kind doc with
+  | `Merlin merlin when available capabilities ->
+    let+ actions =
+      (* TODO: Merlin Jump command that returns all available jump locations for a source code buffer. *)
+      Fiber.parallel_map targets ~f:(fun target ->
+        let+ res = process_jump_request ~merlin ~position:params.range.start ~target in
+        let open Option.O in
+        let* lexing_pos = res in
+        let+ position = Position.of_lexical_position lexing_pos in
+        let uri = Document.uri doc in
+        let range = { Range.start = position; end_ = position } in
+        let title = sprintf "Jump to %s" target in
+        let command =
+          let arguments = [ DocumentUri.yojson_of_t uri; Range.yojson_of_t range ] in
+          Command.create ~title ~command:command_name ~arguments ()
+        in
+        CodeAction.create ~title ~kind:(CodeActionKind.Other "merlin-jump") ~command ())
+    in
+    List.filter_opt actions
+  | _ -> Fiber.return []
+;;

ocaml-lsp-server/src/code_actions/action_jump.mli

@@ -0,0 +1,11 @@
+open Import
+
+val command_name : string
+val available : ShowDocumentClientCapabilities.t option -> bool
+val command_run : 'a Server.t -> ExecuteCommandParams.t -> Json.t Fiber.t
+
+val code_actions
+  :  Document.t
+  -> CodeActionParams.t
+  -> ShowDocumentClientCapabilities.t option
+  -> CodeAction.t list Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -107,6 +107,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : InitializeRes
         then
           view_metrics_command_name
           :: Action_open_related.command_name
+          :: Action_jump.command_name
           :: Document_text_command.command_name
           :: Merlin_config_command.command_name
           :: Dune.commands
@@ -592,6 +593,8 @@ let on_request
     else if String.equal command.command Action_open_related.command_name
     then
       later (fun _state server -> Action_open_related.command_run server command) server
+    else if String.equal command.command Action_jump.command_name
+    then later (fun _state server -> Action_jump.command_run server command) server
     else
       later
         (fun state () ->

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

@@ -1272,6 +1272,105 @@ module M : sig type t = I of int | B of bool end
     |}]
 ;;
 
+let%expect_test "can jump to target" =
+  let source =
+    {ocaml|
+type t = Foo of int | Bar of bool
+let square x = x * x
+let f (x : t) (d : bool) =
+  match x with
+  |Bar x -> x
+  |Foo _ -> d
+|ocaml}
+  in
+  let range =
+    let start = Position.create ~line:5 ~character:5 in
+    let end_ = Position.create ~line:5 ~character:5 in
+    Range.create ~start ~end_
+  in
+  print_code_actions source range ~filter:(find_action "merlin-jump");
+  [%expect
+    {|
+    Code actions:
+    {
+      "command": {
+        "arguments": [
+          "file:///foo.ml",
+          {
+            "end": { "character": 0, "line": 3 },
+            "start": { "character": 0, "line": 3 }
+          }
+        ],
+        "command": "ocamllsp/merlin-jump-to-target",
+        "title": "Jump to fun"
+      },
+      "kind": "merlin-jump",
+      "title": "Jump to fun"
+    }
+    {
+      "command": {
+        "arguments": [
+          "file:///foo.ml",
+          {
+            "end": { "character": 2, "line": 4 },
+            "start": { "character": 2, "line": 4 }
+          }
+        ],
+        "command": "ocamllsp/merlin-jump-to-target",
+        "title": "Jump to match"
+      },
+      "kind": "merlin-jump",
+      "title": "Jump to match"
+    }
+    {
+      "command": {
+        "arguments": [
+          "file:///foo.ml",
+          {
+            "end": { "character": 0, "line": 3 },
+            "start": { "character": 0, "line": 3 }
+          }
+        ],
+        "command": "ocamllsp/merlin-jump-to-target",
+        "title": "Jump to let"
+      },
+      "kind": "merlin-jump",
+      "title": "Jump to let"
+    }
+    {
+      "command": {
+        "arguments": [
+          "file:///foo.ml",
+          {
+            "end": { "character": 3, "line": 6 },
+            "start": { "character": 3, "line": 6 }
+          }
+        ],
+        "command": "ocamllsp/merlin-jump-to-target",
+        "title": "Jump to match-next-case"
+      },
+      "kind": "merlin-jump",
+      "title": "Jump to match-next-case"
+    }
+    {
+      "command": {
+        "arguments": [
+          "file:///foo.ml",
+          {
+            "end": { "character": 3, "line": 5 },
+            "start": { "character": 3, "line": 5 }
+          }
+        ],
+        "command": "ocamllsp/merlin-jump-to-target",
+        "title": "Jump to match-prev-case"
+      },
+      "kind": "merlin-jump",
+      "title": "Jump to match-prev-case"
+    }
+
+       |}]
+;;
+
 let position_of_offset src x =
   assert (0 <= x && x < String.length src);
   let cnum = ref 0

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

@@ -77,8 +77,8 @@ let%expect_test "start/stop" =
         "executeCommandProvider": {
           "commands": [
             "ocamllsp/view-metrics", "ocamllsp/open-related-source",
-            "ocamllsp/show-document-text", "ocamllsp/show-merlin-config",
-            "dune/promote"
+            "ocamllsp/merlin-jump-to-target", "ocamllsp/show-document-text",
+            "ocamllsp/show-merlin-config", "dune/promote"
           ]
         },
         "experimental": {