Merge branch 'master' of github.com:ocamllabs/vscode-ocaml-platform i…

…nto typed_holes

CHANGELOG.md

@@ -2,6 +2,8 @@
 
 # Unreleased
 
+- Add `ocaml.jump` to jump to a specific target. (#1654)
+
 ## 1.22.0
 
 - Fix formatting of cwd path on windows (#1650)

package.json

@@ -258,6 +258,11 @@
         "category": "OCaml",
         "title": "List values that can fill the selected typed-hole"
       },
+      {
+        "command": "ocaml.jump",
+        "category": "OCaml",
+        "title": "List possible parent targets for jumping"
+      },
       {
         "command": "ocaml.navigate-typed-holes",
         "category": "OCaml",
@@ -731,6 +736,14 @@
         },
         "when": "editorLangId == ocaml || editorLangId == reason"
       },
+      {
+        "command": "ocaml.jump",
+        "key": "Alt+J",
+        "args": {
+          "kind": "jump"
+        },
+        "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason"
+      },
       {
         "command": "editor.action.codeAction",
         "key": "Alt+P",

src/custom_requests.ml

@@ -120,3 +120,35 @@ 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
+
+  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
+    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
+
+  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
+
+  val make : uri:Uri.t -> position:Position.t -> params
+
+  val request : (params, response) custom_request
+end

src/extension_commands.ml

@@ -664,6 +664,108 @@ 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 request_possible_targets 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
+      | [] ->
+        show_message `Info "No available targets to jump to.";
+        []
+      | results ->
+        List.map results ~f:(fun (target, pos) ->
+            ( (QuickPickItem.create ~label:("Jump to nearest " ^ target)) ()
+            , (target, pos) ))
+    in
+    let quickPickOptions =
+      QuickPickOptions.create ~title:"Available Jump Targets" ()
+    in
+    Window.showQuickPickItems
+      ~choices:quickPickItems
+      ~options:quickPickOptions
+      ()
+
+  let jump_to_position text_editor position =
+    let open Promise.Syntax in
+    let+ _ =
+      Window.showTextDocument
+        ~document:(TextEditor.document text_editor)
+        ~preserveFocus:true
+        ()
+    in
+    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 process_jump position text_editor client =
+    let open Promise.Syntax in
+    let* successful_targets =
+      request_possible_targets 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
+    | 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 or reason 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
+
 module Navigate_holes = struct
   let extension_name = "Navigate between Typed Holes"
 

src/extension_consts.ml

@@ -71,6 +71,8 @@ module Commands = struct
 
   let construct = ocaml_prefixed "construct"
 
+  let merlin_jump = ocaml_prefixed "jump"
+
   let navigate_typed_holes = ocaml_prefixed "navigate-typed-holes"
 end
 

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,6 +59,20 @@ let construct_item =
   Vscode.TreeItem.set_command item command;
   item
 
+let jump_item =
+  let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"fold-up" ()) 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 navigate_holes_item =
   let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"arrow-up" ()) in
   let label =
@@ -79,7 +93,12 @@ let navigate_holes_item =
   item
 
 let items =
-  [ select_sandbox_item; terminal_item; construct_item; navigate_holes_item ]
+  [ select_sandbox_item
+  ; terminal_item
+  ; construct_item
+  ; jump_item
+  ; navigate_holes_item
+  ]
 
 let getTreeItem ~element = `Value element