Jump Custom Request Client Implementation

CHANGELOG.md

@@ -6,6 +6,7 @@
 
 - Fix formatting of cwd path on windows (#1650)
 - Add `ocaml.construct` to construct an expression from a typedhole. (#1646)
+- Add `ocaml.jump` to jump to a specific target. (#1654)
 
 ## 1.21.0
 
@@ -14,7 +15,7 @@
 - Run ocamllsp -version in workspace dir (#1641)
 - Make it a warning if ocamlc is missing (#1642)
 - Add `1.18.0`, `1.19.0` and `1.20.0~5.3preview` to the list of known versions
-  of ocamllsp (#1644)
+  of ocamllsp (#1644) 
 
 ## 1.20.1
 

package.json

@@ -257,6 +257,11 @@
         "command": "ocaml.construct",
         "category": "OCaml",
         "title": "List values that can fill the selected typed-hole"
+      },
+      {
+        "command": "ocaml.jump",
+        "category": "OCaml",
+        "title": "Jump to a specific target"
       }
     ],
     "configuration": {
@@ -726,6 +731,14 @@
         },
         "when": "editorLangId == ocaml || editorLangId == reason"
       },
+      {
+        "command": "ocaml.jump",
+        "key": "Alt+J",
+        "args": {
+          "kind": "jump"
+        },
+        "when": "editorLangId == ocaml || editorLangId == reason"
+      },
       {
         "command": "editor.action.codeAction",
         "key": "Alt+P",

src/custom_requests.ml

@@ -120,3 +120,39 @@ module Construct = struct
   let request =
     { meth = ocamllsp_prefixed "construct"; encode_params; decode_response }
 end
+
+module Merlin_jump = struct
+  type params =
+    { uri : Uri.t
+    ; position : Position.t
+    }
+
+  type response = (string * Position.t) list option
+
+  let encode_params { uri; position } =
+    let open Jsonoo.Encode in
+    let uri =
+      ("textDocument", object_ [ ("uri", string @@ Uri.toString uri ()) ])
+    in
+    let position = ("position", Position.json_of_t position) in
+    object_ [ uri; position ]
+
+  let decode_response (response : Jsonoo.t) : response =
+    let open Jsonoo.Decode in
+    match
+      field
+        "jumps"
+        (list (fun item ->
+             let target = field "target" string item in
+             let position = field "position" Position.t_of_json item in
+             (target, position)))
+        response
+    with
+    | _ :: _ as items -> Some items
+    | _ -> None
+
+  let make ~uri ~position = { uri; position }
+
+  let request =
+    { meth = ocamllsp_prefixed "jump"; encode_params; decode_response }
+end

src/custom_requests.mli

@@ -58,3 +58,13 @@ module Construct : sig
 
   val request : (params, response) custom_request
 end
+
+module Merlin_jump : sig
+  type params
+
+  type response = (string * Position.t) list option
+
+  val make : uri:Uri.t -> position:Position.t -> params
+
+  val request : (params, response) custom_request
+end

src/extension_commands.ml

@@ -664,6 +664,105 @@ module Construct = struct
     command Extension_consts.Commands.construct handler
 end
 
+module MerlinJump = struct
+  let extension_name = "MerlinJump"
+
+  let is_valid_text_doc textdoc =
+    match TextDocument.languageId textdoc with
+    | "ocaml" | "ocaml.interface" | "reason" | "ocaml.ocamllex" -> true
+    | _ -> false
+
+  let ocaml_lsp_doesnt_support_merlin_jump ocaml_lsp =
+    not (Ocaml_lsp.can_handle_merlin_jump ocaml_lsp)
+
+  let process_jump_target position text_editor client =
+    let doc = TextEditor.document text_editor in
+    let uri = TextDocument.uri doc in
+    Custom_requests.(
+      send_request client Merlin_jump.request (Merlin_jump.make ~uri ~position))
+
+  let display_results (results : Custom_requests.Merlin_jump.response) =
+    let quickPickItems =
+      match results with
+      | Some results ->
+        List.map results ~f:(fun (target, pos) ->
+            ( (QuickPickItem.create ~label:("Jump to nearest " ^ target)) ()
+            , (target, pos) ))
+      | None -> []
+    in
+    let quickPickOptions =
+      QuickPickOptions.create ~title:"Merlin Jump results" ()
+    in
+    Window.showQuickPickItems
+      ~choices:quickPickItems
+      ~options:quickPickOptions
+      ()
+
+  let jump_to_position text_editor position =
+    TextEditor.set_selection
+      text_editor
+      (Selection.makePositions ~anchor:position ~active:position);
+    TextEditor.revealRange
+      text_editor
+      ~range:(Range.makePositions ~start:position ~end_:position)
+      ~revealType:TextEditorRevealType.InCenterIfOutsideViewport
+      ();
+    let _ =
+      Window.showTextDocument
+        ~document:(TextEditor.document text_editor)
+        ~preserveFocus:true
+        ()
+    in
+    ()
+
+  let process_jump position text_editor client =
+    let open Promise.Syntax in
+    let* successful_targets = process_jump_target position text_editor client in
+    let* selected_target = display_results successful_targets in
+    match selected_target with
+    | Some (_res, position) ->
+      jump_to_position text_editor position |> Promise.return
+    | None -> Promise.return ()
+
+  let _jump =
+    let handler (instance : Extension_instance.t) ~args:_ =
+      let jump () =
+        match Window.activeTextEditor () with
+        | None ->
+          Extension_consts.Command_errors.text_editor_must_be_active
+            extension_name
+            ~expl:
+              "The cursor position is used to determine the correct \
+               environment for the jump."
+          |> show_message `Error "%s"
+        | Some text_editor
+          when not (is_valid_text_doc (TextEditor.document text_editor)) ->
+          show_message
+            `Error
+            "Invalid file type. This command only works in ocaml files, ocaml \
+             interface files, reason files or ocamllex files."
+        | Some text_editor -> (
+          match Extension_instance.lsp_client instance with
+          | None -> show_message `Warn "ocamllsp is not running"
+          | Some (_client, ocaml_lsp)
+            when ocaml_lsp_doesnt_support_merlin_jump ocaml_lsp ->
+            show_message
+              `Warn
+              "The installed version of `ocamllsp` does not support Merlin \
+               jump custom requests"
+          | Some (client, _) ->
+            let position =
+              TextEditor.selection text_editor |> Selection.active
+            in
+            let _ = process_jump position text_editor client in
+            ())
+      in
+      let (_ : unit) = jump () in
+      ()
+    in
+    command Extension_consts.Commands.merlin_jump handler
+end
+
 let register extension instance = function
   | Command { id; handler } ->
     let callback = handler instance in

src/extension_consts.ml

@@ -70,6 +70,8 @@ module Commands = struct
   let copy_type_under_cursor = ocaml_prefixed "copy-type-under-cursor"
 
   let construct = ocaml_prefixed "construct"
+
+  let merlin_jump = ocaml_prefixed "jump"
 end
 
 module Command_errors = struct

src/ocaml_lsp.ml

@@ -45,6 +45,7 @@ module Experimental_capabilities = struct
     ; handleTypedHoles : bool
     ; handleTypeEnclosing : bool
     ; handleConstruct : bool
+    ; handleJump : bool
     }
 
   let default =
@@ -53,6 +54,7 @@ module Experimental_capabilities = struct
     ; handleTypedHoles = false
     ; handleTypeEnclosing = false
     ; handleConstruct = false
+    ; handleJump = false
     }
 
   (** Creates [t] given a JSON of form [{ 'handleSwitchImplIntf' : true, .... }] *)
@@ -68,11 +70,13 @@ module Experimental_capabilities = struct
       let handleTypedHoles = has_capability "handleTypedHoles" in
       let handleTypeEnclosing = has_capability "handleTypeEnclosing" in
       let handleConstruct = has_capability "handleConstruct" in
+      let handleJump = has_capability "handleJump" in
       { handleSwitchImplIntf
       ; handleInferIntf
       ; handleTypedHoles
       ; handleTypeEnclosing
       ; handleConstruct
+      ; handleJump
       }
     with Jsonoo.Decode_error err ->
       show_message
@@ -242,3 +246,5 @@ let can_handle_type_enclosing t =
   t.experimental_capabilities.handleTypeEnclosing
 
 let can_handle_construct t = t.experimental_capabilities.handleConstruct
+
+let can_handle_merlin_jump t = t.experimental_capabilities.handleJump

src/ocaml_lsp.mli

@@ -17,6 +17,8 @@ val can_handle_type_enclosing : t -> bool
 
 val can_handle_construct : t -> bool
 
+val can_handle_merlin_jump : t -> bool
+
 module OcamllspSettingEnable : sig
   include Ojs.T
 

src/treeview_commands.ml

@@ -59,7 +59,21 @@ let construct_item =
   Vscode.TreeItem.set_command item command;
   item
 
-let items = [ select_sandbox_item; terminal_item; construct_item ]
+let jump_item =
+  let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"tools" ()) in
+  let label =
+    `TreeItemLabel
+      (Vscode.TreeItemLabel.create ~label:"Jump to a specific target" ())
+  in
+  let item = Vscode.TreeItem.make_label ~label () in
+  let command =
+    Vscode.Command.create ~title:"MerlinJump" ~command:"ocaml.jump" ()
+  in
+  Vscode.TreeItem.set_iconPath item icon;
+  Vscode.TreeItem.set_command item command;
+  item
+
+let items = [ select_sandbox_item; terminal_item; construct_item; jump_item ]
 
 let getTreeItem ~element = `Value element