Construct custom request implementation

CHANGELOG.md

@@ -10,6 +10,7 @@
 - Make it a warning if ocamlc is missing (#1642)
 - Add `1.18.0`, `1.19.0` and `1.20.0~5.3preview` to the list of known versions
   of ocamllsp (#1644)
+- Add `ocaml.construct` to construct an expression from a typedhole. (#1646)
 
 ## 1.20.1
 

package.json

@@ -252,6 +252,11 @@
         "command": "ocaml.copy-type-under-cursor",
         "category": "OCaml",
         "title": "Copy Type Under Cursor"
+      },
+      {
+        "command": "ocaml.construct",
+        "category": "OCaml",
+        "title": "List values that can fill the selected typed-hole"
       }
     ],
     "configuration": {
@@ -714,12 +719,12 @@
         "when": "editorLangId == ocaml || editorLangId == reason"
       },
       {
-        "command": "editor.action.codeAction",
+        "command": "ocaml.construct",
         "key": "Alt+C",
         "args": {
           "kind": "construct"
         },
-        "when": "editorLangId == ocaml"
+        "when": "editorLangId == ocaml || editorLangId == reason"
       },
       {
         "command": "editor.action.codeAction",
@@ -1040,6 +1045,10 @@
         {
           "command": "ocaml.copy-type-under-cursor",
           "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex"
+        },
+        {
+          "command": "ocaml.construct",
+          "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex"
         }
       ],
       "editor/title": [

src/custom_requests.ml

@@ -73,3 +73,50 @@ module Type_enclosing = struct
   let request =
     { meth = ocamllsp_prefixed "typeEnclosing"; encode_params; decode_response }
 end
+
+module Construct = struct
+  type params =
+    { uri : Uri.t
+    ; position : Position.t
+    ; depth : int option
+    ; with_values : [ `None | `Local ] option
+    }
+
+  type response =
+    { position : Range.t
+    ; result : string list
+    }
+
+  let encode_params { uri; position; depth; with_values } =
+    let open Jsonoo.Encode in
+    let uri = ("uri", string @@ Uri.toString uri ()) in
+    let position = ("position", Position.json_of_t position) in
+    let depth =
+      ("depth", Option.(value ~default:null (map ~f:(fun d -> int d) depth)))
+    in
+    let with_values =
+      ( "with_values"
+      , Option.(
+          value
+            ~default:null
+            (map
+               ~f:(fun w ->
+                 match w with
+                 | `None -> string "none"
+                 | `Local -> string "local")
+               with_values)) )
+    in
+    object_ [ uri; position; depth; with_values ]
+
+  let decode_response response =
+    let open Jsonoo.Decode in
+    let position = field "position" Range.t_of_json response in
+    let result = field "result" (list string) response in
+    { position; result }
+
+  let make ~uri ~position ?(depth = None) ?(with_values = None) () =
+    { uri; position; depth; with_values }
+
+  let request =
+    { meth = ocamllsp_prefixed "construct"; encode_params; decode_response }
+end

src/custom_requests.mli

@@ -39,3 +39,22 @@ module Type_enclosing : sig
 
   val request : (params, response) custom_request
 end
+
+module Construct : sig
+  type params
+
+  type response =
+    { position : Range.t
+    ; result : string list
+    }
+
+  val make :
+       uri:Uri.t
+    -> position:Position.t
+    -> ?depth:int option
+    -> ?with_values:[ `None | `Local ] option
+    -> unit
+    -> params
+
+  val request : (params, response) custom_request
+end

src/extension_commands.ml

@@ -164,6 +164,13 @@ module Holes_commands : sig
   val _jump_to_prev_hole : t
 
   val _jump_to_next_hole : t
+
+  val closest_hole :
+       Position.t
+    -> TextEditor.t
+    -> LanguageClient.t
+    -> [< `Next | `Prev ]
+    -> Range.t option Promise.t
 end = struct
   let hole_not_found_msg = "No typed hole was found in this file"
 
@@ -199,6 +206,11 @@ end = struct
       ~revealType:TextEditorRevealType.InCenterIfOutsideViewport
       ()
 
+  let send_request_to_lsp client text_editor =
+    let doc = TextEditor.document text_editor in
+    let uri = TextDocument.uri doc in
+    Custom_requests.send_request client Custom_requests.typedHoles uri
+
   let jump_to_hole jump (instance : Extension_instance.t) ~args =
     (* this command is available (in the command palette) only when a file is
        open *)
@@ -216,12 +228,8 @@ end = struct
         when not (Ocaml_lsp.can_handle_typed_holes ocaml_lsp) ->
         ocaml_lsp_doesn't_support_holes instance ocaml_lsp
       | Some (client, _ocaml_lsp) ->
-        let doc = TextEditor.document text_editor in
-        let uri = TextDocument.uri doc in
         let (_ : unit Promise.t) =
-          let+ holes =
-            Custom_requests.send_request client Custom_requests.typedHoles uri
-          in
+          let+ holes = send_request_to_lsp client text_editor in
           jump
             ~cmd_args:args
             text_editor
@@ -365,6 +373,21 @@ end = struct
               select_hole_range text_editor hole))
   end
 
+  let closest_hole position text_editor client direction =
+    (* We aren't checking if there's the capability to handle typed holes *)
+    let open Promise.Syntax in
+    let+ holes = send_request_to_lsp client text_editor in
+    let sorted_holes = List.sort holes ~compare:Range.compare in
+    match sorted_holes with
+    | [] -> None
+    | holes ->
+      Some
+        (match direction with
+        | `Prev ->
+          Prev_hole.pick_prev_hole position ~sorted_non_empty_holes_list:holes
+        | `Next ->
+          Next_hole.pick_next_hole position ~sorted_non_empty_holes_list:holes)
+
   let _jump_to_next_hole =
     command Extension_consts.Commands.next_hole (jump_to_hole Next_hole.jump)
 
@@ -536,6 +559,111 @@ module Copy_type_under_cursor = struct
     command Extension_consts.Commands.copy_type_under_cursor handler
 end
 
+module Construct = struct
+  let extension_name = "Construct"
+
+  let is_valid_text_doc textdoc =
+    match TextDocument.languageId textdoc with
+    | "ocaml" | "ocaml.interface" | "reason" | "ocaml.ocamllex" -> true
+    | _ -> false
+
+  let ocaml_lsp_doesnt_support_construct ocaml_lsp =
+    not (Ocaml_lsp.can_handle_construct ocaml_lsp)
+
+  let get_construct_results position text_editor client =
+    let doc = TextEditor.document text_editor in
+    let uri = TextDocument.uri doc in
+    Custom_requests.(
+      send_request
+        client
+        Construct.request
+        (Construct.make ~uri ~position ~depth:None ~with_values:None ()))
+
+  let display_results (results : Custom_requests.Construct.response) =
+    let quickPickItems =
+      List.map results.result ~f:(fun res ->
+          (QuickPickItem.create ~label:res (), (res, results.position)))
+    in
+    let quickPickOptions =
+      QuickPickOptions.create ~title:"Construct results" ()
+    in
+    Window.showQuickPickItems
+      ~choices:quickPickItems
+      ~options:quickPickOptions
+      ()
+
+  let insert_to_document text_editor range value =
+    TextEditor.edit
+      text_editor
+      ~callback:(fun ~editBuilder ->
+        Vscode.TextEditorEdit.replace
+          editBuilder
+          ~location:(`Range range)
+          ~value)
+      ()
+
+  let rec process_construct position text_editor client instance =
+    let open Promise.Syntax in
+    let* res = get_construct_results position text_editor client in
+    let* selected_result = display_results res in
+    match selected_result with
+    | Some (value, range) -> (
+      let* value_inserted = insert_to_document text_editor range value in
+      match value_inserted with
+      | true -> (
+        let* new_range =
+          Holes_commands.closest_hole
+            (Range.start range)
+            text_editor
+            client
+            `Next
+        in
+        match new_range with
+        | Some range ->
+          process_construct (Range.end_ range) text_editor client instance
+        | None -> Promise.return ())
+      | false -> Promise.return ())
+    | None -> Promise.return ()
+
+  let _construct =
+    let handler (instance : Extension_instance.t) ~args:_ =
+      let construct () =
+        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 and insert the result."
+          |> 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 or ocamllex 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_construct ocaml_lsp ->
+            show_message
+              `Warn
+              "The installed version of `ocamllsp` does not support construct \
+               custom requests"
+          | Some (client, _) ->
+            let position =
+              TextEditor.selection text_editor |> Selection.active
+            in
+            let _ = process_construct position text_editor client instance in
+            ())
+      in
+      let (_ : unit) = construct () in
+      ()
+    in
+    command Extension_consts.Commands.construct handler
+end
+
 let register extension instance = function
   | Command { id; handler } ->
     let callback = handler instance in

src/extension_consts.ml

@@ -68,6 +68,8 @@ module Commands = struct
   let ask_debug_program = ocaml_prefixed "ask-debug-program"
 
   let copy_type_under_cursor = ocaml_prefixed "copy-type-under-cursor"
+
+  let construct = ocaml_prefixed "construct"
 end
 
 module Command_errors = struct

src/ocaml_lsp.ml

@@ -44,13 +44,15 @@ module Experimental_capabilities = struct
     ; handleInferIntf : bool
     ; handleTypedHoles : bool
     ; handleTypeEnclosing : bool
+    ; handleConstruct : bool
     }
 
   let default =
     { handleSwitchImplIntf = false
     ; handleInferIntf = false
     ; handleTypedHoles = false
     ; handleTypeEnclosing = false
+    ; handleConstruct = false
     }
 
   (** Creates [t] given a JSON of form [{ 'handleSwitchImplIntf' : true, .... }] *)
@@ -65,10 +67,12 @@ module Experimental_capabilities = struct
       let handleInferIntf = has_capability "handleInferIntf" in
       let handleTypedHoles = has_capability "handleTypedHoles" in
       let handleTypeEnclosing = has_capability "handleTypeEnclosing" in
+      let handleConstruct = has_capability "handleConstruct" in
       { handleSwitchImplIntf
       ; handleInferIntf
       ; handleTypedHoles
       ; handleTypeEnclosing
+      ; handleConstruct
       }
     with Jsonoo.Decode_error err ->
       show_message
@@ -236,3 +240,5 @@ let can_handle_typed_holes t = t.experimental_capabilities.handleTypedHoles
 
 let can_handle_type_enclosing t =
   t.experimental_capabilities.handleTypeEnclosing
+
+let can_handle_construct t = t.experimental_capabilities.handleConstruct

src/ocaml_lsp.mli

@@ -15,6 +15,8 @@ val can_handle_typed_holes : t -> bool
 
 val can_handle_type_enclosing : t -> bool
 
+val can_handle_construct : t -> bool
+
 module OcamllspSettingEnable : sig
   include Ojs.T
 

src/treeview_commands.ml

@@ -43,7 +43,23 @@ let terminal_item =
   Vscode.TreeItem.set_command item command;
   item
 
-let items = [ select_sandbox_item; terminal_item ]
+let construct_item =
+  let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"tools" ()) in
+  let label =
+    `TreeItemLabel
+      (Vscode.TreeItemLabel.create
+         ~label:"List values that can fill the selected typed-hole"
+         ())
+  in
+  let item = Vscode.TreeItem.make_label ~label () in
+  let command =
+    Vscode.Command.create ~title:"Construct" ~command:"ocaml.construct" ()
+  in
+  Vscode.TreeItem.set_iconPath item icon;
+  Vscode.TreeItem.set_command item command;
+  item
+
+let items = [ select_sandbox_item; terminal_item; construct_item ]
 
 let getTreeItem ~element = `Value element
 

yarn.lock

@@ -2645,9 +2645,9 @@ __metadata:
   linkType: hard
 
 "electron-to-chromium@npm:^1.5.41":
-  version: 1.5.57
-  resolution: "electron-to-chromium@npm:1.5.57"
-  checksum: 10c0/42b969681985016be6069ae68cf29e84ba3f2191fcb7f9d3355e83e81da8dbd100e4b5c9d69b88637003e06dc1860125a50332ec0caee49fd9c2c4ab62feb288
+  version: 1.5.60
+  resolution: "electron-to-chromium@npm:1.5.60"
+  checksum: 10c0/934d8d1383ffee4f5f94586ebf0afd133c841002fa3b3cc60b8f6c2af62cd1a73b40cf9fd4cfabba854c3ea5f1df0ecb69f0f9d2e3f913e6b7df7461685b4955
   languageName: node
   linkType: hard