Draft:Refactor extract custom query

CHANGES.md

@@ -1,3 +1,9 @@
+# Unreleased
+
+## Features
+
+- Add custom [`ocamllsp/refactorExtract`](https://github.com/ocaml/ocaml-lsp/blob/ocaml-lsp-server/docs/ocamllsp/refactorExtract-spec.md) request (#1545)
+
 # 1.23.0
 
 ## Features

ocaml-lsp-server/docs/ocamllsp/refactorExtract.md

@@ -0,0 +1,42 @@
+# Refactor Extract Request
+
+## Description
+
+Provides commands to extract an arbitrary region into a fresh let binding.
+
+## Client Capability
+
+There is no client capability relative to this request.
+
+## Server capability
+
+- property name: `refactorExtract`
+- property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/refactorExtract`
+- params:
+
+  ```json
+  {
+    "uri": TextDocumentIdentifier,
+    "start": Position,
+    "stop": Position,
+    "extract_name?": string,
+  }
+  ```
+
+`start` and `stop` represents the region to be extracted. The `extract_name` parameter allows choosing the name of the generated let binding. If `extract_name` is not specified, a name not taken in the scope is chosen.
+
+## Response
+
+```json
+{
+  "position": Range,
+  "content": string,
+  "selection_range": Range
+}
+```
+
+The result contains the range (`position`) to be replaced (describing the selected region), the output intended to be substituted (`content`) and the range of the identifier of the generated binding (`selection_range`) which allows renaming it easily.

ocaml-lsp-server/src/custom_requests/custom_request.ml

@@ -10,3 +10,4 @@ module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation
 module Type_search = Req_type_search
 module Merlin_jump = Req_merlin_jump
+module Refactor_extract = Req_refactor_extract

ocaml-lsp-server/src/custom_requests/custom_request.mli

@@ -12,3 +12,4 @@ module Wrapping_ast_node = Req_wrapping_ast_node
 module Get_documentation = Req_get_documentation
 module Type_search = Req_type_search
 module Merlin_jump = Req_merlin_jump
+module Refactor_extract = Req_refactor_extract

ocaml-lsp-server/src/custom_requests/req_refactor_extract.ml

@@ -0,0 +1,91 @@
+open Import
+
+let capability = "refactorExtract", `Bool true
+let meth = "ocamllsp/refactorExtract"
+
+module Request_params = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; start : Position.t
+    ; stop : Position.t
+    ; extract_name : string option
+    }
+
+  let create ?extract_name ~text_document ~start ~stop () =
+    { text_document; start; stop; extract_name }
+  ;;
+
+  let yojson_of_t { text_document; start; stop; extract_name } =
+    match TextDocumentIdentifier.yojson_of_t text_document with
+    | `Assoc assoc ->
+      let start = "start", Position.yojson_of_t start in
+      let stop = "stop", Position.yojson_of_t stop in
+      let extract_name =
+        "extract_name", Option.fold extract_name ~init:`Null ~f:(fun _ s -> `String s)
+      in
+      `Assoc (start :: stop :: extract_name :: assoc)
+    | _ -> (* unreachable *) assert false
+  ;;
+
+  let t_of_yojson json =
+    let open Yojson.Safe.Util in
+    let text_document = json |> TextDocumentIdentifier.t_of_yojson in
+    let start = json |> member "start" |> Position.t_of_yojson in
+    let stop = json |> member "stop" |> Position.t_of_yojson in
+    let extract_name = json |> member "extract_name" |> to_string_option in
+    create ?extract_name ~text_document ~start ~stop ()
+  ;;
+end
+
+type t =
+  { position : Range.t
+  ; content : string
+  ; selection_range : Range.t
+  }
+
+let yojson_of_t { position; content; selection_range } =
+  `Assoc
+    [ "position", Range.yojson_of_t position
+    ; "content", `String content
+    ; "selection_range", Range.yojson_of_t selection_range
+    ]
+;;
+
+let with_pipeline state uri f =
+  let doc = Document_store.get state.State.store uri in
+  match Document.kind doc with
+  | `Other -> Fiber.return `Null
+  | `Merlin merlin ->
+    (match Document.Merlin.kind merlin with
+     | Document.Kind.Intf ->
+       (* Extraction makes no sense if its called from an interface. *)
+       Fiber.return `Null
+     | Document.Kind.Impl -> Document.Merlin.with_pipeline_exn merlin f)
+;;
+
+let dispatch ~start ~stop ~extract_name pipeline =
+  let start = Position.logical start in
+  let end_ = Position.logical stop in
+  let buffer = Mpipeline.raw_source pipeline in
+  let command =
+    Query_protocol.Refactor_extract_region (start, end_, extract_name, buffer)
+  in
+  let { Query_protocol.loc; content; selection_range } =
+    Query_commands.dispatch pipeline command
+  in
+  yojson_of_t
+    { position = Range.of_loc loc
+    ; content
+    ; selection_range = Range.of_loc selection_range
+    }
+;;
+
+let on_request ~params state =
+  Fiber.of_thunk (fun () ->
+    let params = (Option.value ~default:(`Assoc []) params :> Yojson.Safe.t) in
+    let Request_params.{ text_document; start; stop; extract_name } =
+      Request_params.t_of_yojson params
+    in
+    let uri = text_document.uri in
+    with_pipeline state uri @@ dispatch ~start ~stop ~extract_name)
+;;

ocaml-lsp-server/src/custom_requests/req_refactor_extract.mli

@@ -0,0 +1,21 @@
+open Import
+
+module Request_params : sig
+  type t
+
+  val create
+    :  ?extract_name:string
+    -> text_document:Lsp.Types.TextDocumentIdentifier.t
+    -> start:Position.t
+    -> stop:Position.t
+    -> unit
+    -> t
+
+  val yojson_of_t : t -> Json.t
+end
+
+type t
+
+val capability : string * Json.t
+val meth : string
+val on_request : params:Jsonrpc.Structured.t option -> State.t -> Json.t Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -98,6 +98,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : InitializeRes
               ; Req_get_documentation.capability
               ; Req_construct.capability
               ; Req_type_search.capability
+              ; Req_refactor_extract.capability
               ; Req_merlin_jump.capability
               ] )
         ]
@@ -541,6 +542,7 @@ let on_request
        ; Req_wrapping_ast_node.meth, Req_wrapping_ast_node.on_request
        ; Req_type_search.meth, Req_type_search.on_request
        ; Req_construct.meth, Req_construct.on_request
+       ; Req_refactor_extract.meth, Req_refactor_extract.on_request
        ; ( Semantic_highlighting.Debug.meth_request_full
          , Semantic_highlighting.Debug.on_request_full )
        ; ( Req_hover_extended.meth

ocaml-lsp-server/test/e2e-new/dune

@@ -57,6 +57,7 @@
     merlin_call_compatible
     diagnostics_filter
     metrics
+    refactor_extract
     semantic_hl_data
     semantic_hl_helpers
     semantic_hl_tests

ocaml-lsp-server/test/e2e-new/refactor_extract.ml

@@ -0,0 +1,186 @@
+open Test.Import
+module Req = Ocaml_lsp_server.Custom_request.Refactor_extract
+
+module Util = struct
+  let call_extract ?extract_name ~start ~stop client =
+    let uri = DocumentUri.of_path "test.ml" in
+    let text_document = TextDocumentIdentifier.create ~uri in
+    let params =
+      Req.Request_params.create ?extract_name ~text_document ~start ~stop ()
+      |> Req.Request_params.yojson_of_t
+      |> Jsonrpc.Structured.t_of_yojson
+      |> Option.some
+    in
+    let req = Lsp.Client_request.UnknownRequest { meth = Req.meth; params } in
+    Client.request client req
+  ;;
+
+  let test ?extract_name ~start ~stop source =
+    let request client =
+      let open Fiber.O in
+      let+ response = call_extract ?extract_name ~start ~stop client in
+      Test.print_result response
+    in
+    Helpers.test source request
+  ;;
+end
+
+let%expect_test "Example sample from merlin 1" =
+  let source =
+    {|module type EMPTY = sig end
+let f () : (module EMPTY) =
+  (module struct
+    let const_name2 = assert false
+    let secret = String.make 100 '@'
+  end)
+|}
+  in
+  let start = Position.create ~line:4 ~character:33
+  and stop = Position.create ~line:4 ~character:36 in
+  Util.test ~start ~stop source;
+  [%expect
+    {|
+    {
+      "position": {
+        "end": { "character": 6, "line": 5 },
+        "start": { "character": 0, "line": 1 }
+      },
+      "content": "let const_name1 = '@'\nlet f () : (module EMPTY) =\n  (module struct\n    let const_name2 = assert false\n    let secret = String.make 100 const_name1\n  end)",
+      "selection_range": {
+        "end": { "character": 15, "line": 1 },
+        "start": { "character": 4, "line": 1 }
+      }
+    } |}]
+;;
+
+let%expect_test "Example sample from merlin 2" =
+  let source =
+    {|let fun_name1 () = ()
+
+let all_empty l =
+  List.for_all
+    (function
+      | [] -> true
+      | _ -> false)
+    l
+|}
+  in
+  let start = Position.create ~line:4 ~character:4
+  and stop = Position.create ~line:6 ~character:19 in
+  Util.test ~start ~stop source;
+  [%expect
+    {|
+    {
+      "position": {
+        "end": { "character": 5, "line": 7 },
+        "start": { "character": 0, "line": 2 }
+      },
+      "content": "let fun_name2 = (function | [] -> true | _ -> false)\nlet all_empty l =\n  List.for_all\n    fun_name2 \n    l",
+      "selection_range": {
+        "end": { "character": 13, "line": 2 },
+        "start": { "character": 4, "line": 2 }
+      }
+    } |}]
+;;
+
+let%expect_test "Example sample from merlin 3" =
+  let source =
+    {|(* A comment *)
+let z = "..."
+
+let test x y =
+  let fun_name2 = Fun.id in
+  let m =
+    let m = print_endline (x ^ y ^ z) in
+    m
+  in
+  m
+|}
+  in
+  let start = Position.create ~line:6 ~character:12
+  and stop = Position.create ~line:6 ~character:37 in
+  Util.test ~extract_name:"print_xyz" ~start ~stop source;
+  [%expect
+    {|
+    {
+      "position": {
+        "end": { "character": 3, "line": 9 },
+        "start": { "character": 0, "line": 3 }
+      },
+      "content": "let print_xyz (x) (y) = print_endline (x ^ (y ^ z))\nlet test x y =\n  let fun_name2 = Fun.id in\n  let m =\n    let m = print_xyz x y in\n    m\n  in\n  m",
+      "selection_range": {
+        "end": { "character": 13, "line": 3 },
+        "start": { "character": 4, "line": 3 }
+      }
+    }
+    |}]
+;;
+
+let%expect_test "Example sample from merlin 4" =
+  let source =
+    {|let f =
+  print_endline "Wild side effect!";
+  1 :: [ 2; 3; 4 ] 
+|}
+  in
+  let start = Position.create ~line:1 ~character:12
+  and stop = Position.create ~line:1 ~character:37 in
+  Util.test ~extract_name:"show" ~start ~stop source;
+  [%expect
+    {|
+    {
+      "position": {
+        "end": { "character": 18, "line": 2 },
+        "start": { "character": 0, "line": 0 }
+      },
+      "content": "let show = \"Wild side effect!\"\nlet f =\n  print_endline show;\n  1 :: [ 2; 3; 4 ]",
+      "selection_range": {
+        "end": { "character": 8, "line": 0 },
+        "start": { "character": 4, "line": 0 }
+      }
+    }
+    |}]
+;;
+
+let%expect_test "Example sample from merlin 5" =
+  let source =
+    {|class a =
+  let inner_expr =
+    let bar = 20 in
+    object
+      method foo = bar
+    end
+  in
+  object
+    method x = (Fun.const 10) ()
+    method y = print_endline
+    method z =
+      let x =
+        object
+          method x = "foobar"
+        end
+      in
+      x
+  end
+
+and b = object end
+|}
+  in
+  let start = Position.create ~line:2 ~character:4
+  and stop = Position.create ~line:5 ~character:37 in
+  Util.test ~extract_name:"outsider_expr" ~start ~stop source;
+  [%expect
+    {|
+    {
+      "position": {
+        "end": { "character": 5, "line": 17 },
+        "start": { "character": 0, "line": 0 }
+      },
+      "content": "let outsider_expr () = let bar = 20 in object method foo = bar end\nclass a =\n  let inner_expr =\n    outsider_expr ()\n  in\n  object\n    method x = (Fun.const 10) ()\n    method y = print_endline\n    method z =\n      let x =\n        object\n          method x = \"foobar\"\n        end\n      in\n      x\n  end",
+      "selection_range": {
+        "end": { "character": 17, "line": 0 },
+        "start": { "character": 4, "line": 0 }
+      }
+    }
+    |}]
+;;

ocaml-lsp-server/test/e2e-new/start_stop.ml

@@ -96,6 +96,7 @@ let%expect_test "start/stop" =
             "handleGetDocumentation": true,
             "handleConstruct": true,
             "handleTypeSearch": true,
+            "refactorExtract": true,
             "handleJump": true
           }
         },