From 3d4c00300e08eb8a7ec126d6e7f71d219f92a3ef Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 2 Dec 2024 12:43:31 +0100 Subject: [PATCH] Navigating Typed Holes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Ulysse Gérard --- CHANGELOG.md | 2 + package.json | 14 +++++ src/extension_commands.ml | 107 ++++++++++++++++++++++++++++++++++++++ src/extension_consts.ml | 1 + src/settings.ml | 8 +++ src/settings.mli | 1 + src/treeview_commands.ml | 23 +++++++- 7 files changed, 155 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bfd5bca84..88be2bd4f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ # Unreleased +- Add `ocaml.navigate-typed-holes` to navigate to different typed holes. (#1666) + ## 1.24.0 - Add `ocaml.commands.construct.recursiveCalls` setting to configure construct chaining. (#1673) diff --git a/package.json b/package.json index 66fc4a3fa..c913a036c 100644 --- a/package.json +++ b/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": [ diff --git a/src/extension_commands.ml b/src/extension_commands.ml index d0f1795eb..ae6123ac1 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -753,6 +753,113 @@ module MerlinJump = struct ;; 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 diff --git a/src/extension_consts.ml b/src/extension_consts.ml index 90da2c490..519b14a83 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -35,6 +35,7 @@ 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" + let navigate_typed_holes = ocaml_prefixed "navigate-typed-holes" end module Command_errors = struct diff --git a/src/settings.ml b/src/settings.ml index 0130a8886..0b9687cbd 100644 --- a/src/settings.ml +++ b/src/settings.ml @@ -149,6 +149,14 @@ let server_syntaxDocumentation_setting = ~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 diff --git a/src/settings.mli b/src/settings.mli index 679cc49b8..f3cbd8d22 100644 --- a/src/settings.mli +++ b/src/settings.mli @@ -39,4 +39,5 @@ val server_codelens_setting : bool setting val server_extendedHover_setting : bool setting val server_duneDiagnostics_setting : bool setting val server_syntaxDocumentation_setting : bool setting +val server_typedHolesConstructAfterNavigate_setting : bool setting val server_constructRecursiveCalls_setting : bool setting diff --git a/src/treeview_commands.ml b/src/treeview_commands.ml index aede34816..2ab7270e9 100644 --- a/src/treeview_commands.ml +++ b/src/treeview_commands.ml @@ -66,7 +66,28 @@ let jump_item = 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 let getChildren ?element () =