Navigating Typed holes

CHANGELOG.md

@@ -2,6 +2,7 @@
 
 # Unreleased
 
+- Add `ocaml.navigate-typed-holes` to navigate to different typed holes. (#1666)
 - Add `ocaml.commands.construct.recursiveCalls` setting to configure construct chaining. (#1673)
 
 ## 1.23.0

package.json

@@ -262,6 +262,11 @@
         "command": "ocaml.jump",
         "category": "OCaml",
         "title": "List possible parent targets for jumping"
+      },
+      {
+        "command": "ocaml.navigate-typed-holes",
+        "category": "OCaml",
+        "title": "Lists typed holes in the file for navigation."
       }
     ],
     "configuration": {
@@ -306,6 +311,11 @@
           "default": false,
           "markdownDescription": "Enable/Disable syntax documentation"
         },
+        "ocaml.commands.typedHoles.constructAfterNavigate": {
+          "type": "boolean",
+          "default": false,
+          "markdownDescription": "When enabled, list values that can fill a typed hole after navigating to it."
+        },
         "ocaml.commands.construct.recursiveCalls": {
           "type": "boolean",
           "default": true,
@@ -1067,6 +1077,10 @@
         {
           "command": "ocaml.construct",
           "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex"
+        },
+        {
+          "command": "ocaml.navigate-typed-holes",
+          "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason"
         }
       ],
       "editor/title": [

src/extension_commands.ml

@@ -769,6 +769,117 @@ module MerlinJump = struct
     command Extension_consts.Commands.merlin_jump handler
 end
 
+module Navigate_holes = struct
+  let extension_name = "Navigate between Typed Holes"
+
+  let ocaml_lsp_doesnt_support_typed_holes ocaml_lsp =
+    not (Ocaml_lsp.can_handle_typed_holes ocaml_lsp)
+
+  let is_valid_text_doc textdoc =
+    match TextDocument.languageId textdoc with
+    | "ocaml" | "ocaml.interface" | "reason" -> true
+    | _ -> false
+
+  let send_request_to_lsp client doc =
+    let uri = TextDocument.uri doc in
+    Custom_requests.send_request client Custom_requests.typedHoles uri
+
+  let display_results (results : Range.t list) text_document =
+    let quickPickItems =
+      List.map results ~f:(fun res ->
+          let line = Position.line @@ Range.end_ res in
+          ( QuickPickItem.create
+              ~label:(Printf.sprintf "Line %d" line)
+              ~detail:
+                (Printf.sprintf
+                   "%s"
+                   (TextLine.text @@ TextDocument.lineAt ~line text_document))
+              ()
+          , (res, ()) ))
+    in
+    let quickPickOptions = QuickPickOptions.create ~title:"Typed Holes" () in
+    Window.showQuickPickItems
+      ~choices:quickPickItems
+      ~options:quickPickOptions
+      ()
+
+  let jump_to_hole range text_editor =
+    let open Promise.Syntax in
+    let+ _ =
+      Window.showTextDocument
+        ~document:(TextEditor.document text_editor)
+        ~preserveFocus:true
+        ()
+    in
+    let new_selection =
+      let anchor = Range.start range in
+      let active = Range.end_ range in
+      Selection.makePositions ~anchor ~active
+    in
+    TextEditor.set_selection text_editor new_selection;
+    TextEditor.revealRange
+      text_editor
+      ~range
+      ~revealType:TextEditorRevealType.InCenterIfOutsideViewport
+      ()
+
+  let handle_hole_navigation text_editor client instance =
+    let open Promise.Syntax in
+    let doc = TextEditor.document text_editor in
+    let* hole_positions = send_request_to_lsp client doc in
+    match hole_positions with
+    | [] ->
+      show_message `Info "No typed holes found in the file.";
+      Promise.return ()
+    | holes -> (
+      let* selected_hole = display_results holes doc in
+      match selected_hole with
+      | Some (range, ()) -> (
+        let* () = jump_to_hole range text_editor in
+        match
+          Settings.(get server_typedHolesConstructAfterNavigate_setting)
+        with
+        | Some true ->
+          Construct.process_construct
+            (Range.end_ range)
+            text_editor
+            client
+            instance
+        | Some false | None -> Promise.return ())
+      | None -> Promise.return ())
+
+  let _holes =
+    let handler (instance : Extension_instance.t) ~args:_ =
+      match Window.activeTextEditor () with
+      | None ->
+        Extension_consts.Command_errors.text_editor_must_be_active
+          extension_name
+          ~expl:
+            "This command only works in an active editor because it's based on \
+             the content of the editor"
+        |> 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."
+      | 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_typed_holes ocaml_lsp ->
+          show_message
+            `Warn
+            "The installed version of `ocamllsp` does not support typed hole \
+             navigation"
+        | Some (client, _) ->
+          let _ = handle_hole_navigation text_editor client instance in
+          ())
+    in
+    command Extension_consts.Commands.navigate_typed_holes handler
+end
+
 let register extension instance = function
   | Command { id; handler } ->
     let callback = handler instance in

src/extension_consts.ml

@@ -72,6 +72,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
 
 module Command_errors = struct

src/settings.ml

@@ -142,6 +142,13 @@ let server_syntaxDocumentation_setting =
     ~of_json:Jsonoo.Decode.bool
     ~to_json:Jsonoo.Encode.bool
 
+let server_typedHolesConstructAfterNavigate_setting =
+  create_setting
+    ~scope:ConfigurationTarget.Workspace
+    ~key:"ocaml.commands.typedHoles.constructAfterNavigate"
+    ~of_json:Jsonoo.Decode.bool
+    ~to_json:Jsonoo.Encode.bool
+
 let server_constructRecursiveCalls_setting =
   create_setting
     ~scope:ConfigurationTarget.Workspace

src/settings.mli

@@ -46,4 +46,6 @@ val server_duneDiagnostics_setting : bool setting
 
 val server_syntaxDocumentation_setting : bool setting
 
+val server_typedHolesConstructAfterNavigate_setting : bool setting
+
 val server_constructRecursiveCalls_setting : bool setting

src/treeview_commands.ml

@@ -73,7 +73,32 @@ let jump_item =
   Vscode.TreeItem.set_command item command;
   item
 
-let items = [ select_sandbox_item; terminal_item; construct_item; jump_item ]
+let navigate_holes_item =
+  let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"breakpoints-activate" ()) in
+  let label =
+    `TreeItemLabel
+      (Vscode.TreeItemLabel.create
+         ~label:"Navigate to different typed holes"
+         ())
+  in
+  let item = Vscode.TreeItem.make_label ~label () in
+  let command =
+    Vscode.Command.create
+      ~title:"Navigate typed holes"
+      ~command:"ocaml.navigate-typed-holes"
+      ()
+  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
+  ; navigate_holes_item
+  ]
 
 let getTreeItem ~element = `Value element