diff --git a/CHANGELOG.md b/CHANGELOG.md index 33c2c076d..ce1003bde 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ # Unreleased +- Add `ocaml.navigate-typed-holes` to navigate between typed holes. (#1666) + ## 1.25.0 - Add `ocaml.search-by-type` to search for values using their type signature (#1626) diff --git a/package.json b/package.json index 16f9edef6..a17fe567b 100644 --- a/package.json +++ b/package.json @@ -267,6 +267,11 @@ "command": "ocaml.search-by-type", "category": "OCaml", "title": "Search a value by type or polarity" + }, + { + "command": "ocaml.navigate-typed-holes", + "category": "OCaml", + "title": "List typed holes in the file for navigation" } ], "configuration": { @@ -311,6 +316,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, @@ -1081,6 +1091,10 @@ { "command": "ocaml.search-by-type", "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 0b658aa96..4a6bee254 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -950,6 +950,186 @@ module Search_by_type = 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 show_selection selection text_editor = + TextEditor.set_selection text_editor selection; + TextEditor.revealRange + text_editor + ~range:(Selection.to_range selection) + ~revealType:TextEditorRevealType.InCenterIfOutsideViewport + () + ;; + + let jump_to_range range text_editor = + let open Promise.Syntax in + let+ _ = + Window.showTextDocument + ~document:(TextEditor.document text_editor) + ~preserveFocus:true + () + in + let selection = + let anchor = Range.start range in + let active = Range.end_ range in + Selection.makePositions ~anchor ~active + in + show_selection selection text_editor + ;; + + module QuickPickItemWithRange = struct + type t = + { item : QuickPickItem.t + ; range : Range.t + } + + let t_of_js js = + let range = Ojs.get_prop_ascii js "pl_range" |> Range.t_of_js in + let item = QuickPickItem.t_of_js js in + { item; range } + ;; + + let t_to_js t = + let item = QuickPickItem.t_to_js t.item in + Ojs.set_prop_ascii item "pl_range" (Range.t_to_js t.range); + item + ;; + end + + module QuickPick = Vscode.QuickPick.Make (QuickPickItemWithRange) + + let display_results (results : Range.t list) text_editor client instance = + let open Promise.Syntax in + let selected_item = ref false in + let text_document = TextEditor.document text_editor in + let quickPickItems = + List.map results ~f:(fun range -> + let line = Position.line @@ Range.end_ range in + let item = + QuickPickItem.create + ~label:(Printf.sprintf "Line %d" line) + ~description:(TextLine.text @@ TextDocument.lineAt ~line text_document) + () + in + { QuickPickItemWithRange.item; range }) + in + let quickPick = + QuickPick.set + (Window.createQuickPick (module QuickPickItemWithRange) ()) + ~title:"Typed Holes" + ~activeItems:[] + ~busy:false + ~enabled:true + ~placeholder:"Use arrow keys to preview / Select to jump to it" + ~selectedItems:[] + ~ignoreFocusOut:false + ~items:quickPickItems + ~matchOnDescription:true + ~buttons:[] + () + in + let _disposable = + QuickPick.onDidChangeActive + quickPick + ~listener:(function + | { range; _ } :: _ -> + show_selection + (Selection.makePositions + ~anchor:(Range.start range) + ~active:(Range.end_ range)) + text_editor + | _ -> ()) + () + in + let _disposable = + QuickPick.onDidAccept + quickPick + ~listener:(fun () -> + match QuickPick.selectedItems quickPick with + | Some (item :: _) -> + ignore + (let range = item.range in + let* () = jump_to_range range text_editor in + selected_item := true; + match Settings.(get server_typedHolesConstructAfterNavigate_setting) with + | Some true -> + Construct.process_construct + (Range.end_ range) + text_editor + client + instance + | Some false | None -> Promise.return ()) + | _ -> ()) + () + in + let _disposable = + let initial_selection = TextEditor.selection text_editor in + QuickPick.onDidHide + quickPick + ~listener:(fun () -> + if !selected_item then () else show_selection initial_selection text_editor; + QuickPick.dispose quickPick) + () + in + QuickPick.show quickPick + ;; + + 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." + | holes -> display_results holes text_editor client instance + ;; + + 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 3c311d42a..bd64772e5 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -36,6 +36,7 @@ module Commands = struct let construct = ocaml_prefixed "construct" let merlin_jump = ocaml_prefixed "jump" let search_by_type = ocaml_prefixed "search-by-type" + 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 66ab4f187..bc7f5250d 100644 --- a/src/treeview_commands.ml +++ b/src/treeview_commands.ml @@ -84,8 +84,31 @@ let type_search_item = item ;; +let navigate_holes_item = + let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"breakpoints-activate" ()) in + let label = + `TreeItemLabel (Vscode.TreeItemLabel.create ~label:"Navigate between 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; type_search_item ] + [ select_sandbox_item + ; terminal_item + ; construct_item + ; jump_item + ; type_search_item + ; navigate_holes_item + ] ;; let getTreeItem ~element = `Value element