Navigating Typed Holes (#1666)

* Navigating Typed Holes

Co-authored-by: Ulysse Gérard <thevoodoos@gmail.com>

* use low level QuickPick api

* show selection when moving

* remove un-needed ignore

* move to initial cursor position if no selection

* fix bug

* Update package.json

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* Update CHANGELOG.md

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* Update src/extension_commands.ml

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* Update src/extension_commands.ml

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* Update src/treeview_commands.ml

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* remove unused

* linting

* use a boolean to keep state and go back to same selection

* refactor

* Update package.json

Co-authored-by: Sora Morimoto <sora@morimoto.io>

* Use custom QuickPickItems ot carry the Range.

* Update src/extension_commands.ml

Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>

* search filter on description

---------

Co-authored-by: Ulysse Gérard <thevoodoos@gmail.com>
Co-authored-by: Ulysse <5031221+voodoos@users.noreply.github.com>
Co-authored-by: Sora Morimoto <sora@morimoto.io>

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)

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": [

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

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

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

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

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