Construct custom request implementation

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": "Construct"
       }
     ],
     "configuration": {
@@ -719,7 +724,7 @@
         "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

@@ -162,6 +162,9 @@ module Holes_commands : sig
   val _jump_to_prev_hole : t
 
   val _jump_to_next_hole : t
+
+  val hole_position :
+    TextEditor.t -> LanguageClient.t -> [< `Next | `Prev ] -> Range.t Promise.t
 end = struct
   let hole_not_found_msg = "No typed hole was found in this file"
 
@@ -197,6 +200,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 *)
@@ -214,12 +222,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
@@ -363,6 +367,24 @@ end = struct
               select_hole_range text_editor hole))
   end
 
+  let hole_position text_editor client direction =
+    let open Promise.Syntax in
+    let (range : Range.t Promise.t) =
+      let+ holes = send_request_to_lsp client text_editor in
+      let sorted_holes = List.sort holes ~compare:Range.compare in
+      let current_pos = current_cursor_pos text_editor in
+      match direction with
+      | `Prev ->
+        Prev_hole.pick_prev_hole
+          current_pos
+          ~sorted_non_empty_holes_list:sorted_holes
+      | `Next ->
+        Next_hole.pick_next_hole
+          current_pos
+          ~sorted_non_empty_holes_list:sorted_holes
+    in
+    range
+
   let _jump_to_next_hole =
     command Extension_consts.Commands.next_hole (jump_to_hole Next_hole.jump)
 
@@ -534,6 +556,105 @@ 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 rec display_results ~text_editor:_ ~position:_
+      (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
+      ()
+
+  and 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 ~text_editor ~position 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.hole_position text_editor client `Prev
+        in
+        process_construct (Range.end_ new_range) text_editor client instance
+      | false -> Promise.return ())
+    | None -> Promise.return ()
+
+  and insert_to_document text_editor range value =
+    TextEditor.edit
+      text_editor
+      ~callback:(fun ~editBuilder ->
+        Vscode.TextEditorEdit.replace
+          editBuilder
+          ~location:(`Range range)
+          ~value)
+      ()
+
+  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

@@ -45,6 +45,7 @@ module Experimental_capabilities = struct
     ; handleInferIntf : bool
     ; handleTypedHoles : bool
     ; handleTypeEnclosing : bool
+    ; handleConstruct : bool
     }
 
   let default =
@@ -53,6 +54,7 @@ module Experimental_capabilities = struct
     ; handleInferIntf = false
     ; handleTypedHoles = false
     ; handleTypeEnclosing = false
+    ; handleConstruct = false
     }
 
   (** Creates [t] given a JSON of form [{ 'handleSwitchImplIntf' : true, .... }] *)
@@ -68,11 +70,13 @@ 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
       { interfaceSpecificLangId
       ; handleSwitchImplIntf
       ; handleInferIntf
       ; handleTypedHoles
       ; handleTypeEnclosing
+      ; handleConstruct
       }
     with Jsonoo.Decode_error err ->
       show_message
@@ -237,3 +241,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