From 8b9b60b59f9b38ca7bbd7df5a62ded48ea2cb98e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=C3=A9o=20Arnouts?= Date: Fri, 18 Jul 2025 15:31:56 +0200 Subject: [PATCH 1/3] Add test for `refactor-extract` code action. --- .../test/e2e-new/action_extract.ml | 150 ++++++++---------- 1 file changed, 62 insertions(+), 88 deletions(-) diff --git a/ocaml-lsp-server/test/e2e-new/action_extract.ml b/ocaml-lsp-server/test/e2e-new/action_extract.ml index dcef2d2e4..ad71e07d5 100644 --- a/ocaml-lsp-server/test/e2e-new/action_extract.ml +++ b/ocaml-lsp-server/test/e2e-new/action_extract.ml @@ -1,95 +1,53 @@ -let extract_local_test = Code_actions.code_action_test ~title:"Extract local" -let extract_function_test = Code_actions.code_action_test ~title:"Extract function" +let extract_test = Code_actions.code_action_test ~title:"Extract expression" let%expect_test "extract local constant" = - extract_local_test + extract_test {| let f = 0 + $1$ |}; [%expect {| + let const_name1 = 1 let f = - let var_name = 1 in - 0 + var_name |}] -;; - -let%expect_test "extract local expression" = - extract_local_test - {| -let f = - let x = 2 in - $0 + 1 + x$ + 1 -|}; - [%expect - {| - let f = - let x = 2 in - let var_name = 0 + 1 + x in - var_name + 1 |}] + 0 + const_name1 + |}] ;; let%expect_test "extract function single parameter" = - extract_function_test + extract_test {| +let fun_name1 () = () let f x = $(x * 2)$ + 3 |}; [%expect {| - let fun_name x = (x * 2) - + let fun_name1 () = () + let fun_name2 (x) = x * 2 let f x = - fun_name x + 3 |}] + fun_name2 x + 3 + |}] ;; let%expect_test "extract function multiple parameter" = - extract_function_test + extract_test {| let f x = - let y = 0 in - $(x * y)$ + 3 +let y = 0 in +$(x * y)$ + 3 |}; [%expect {| - let fun_name y x = (x * y) - + let fun_name1 (y) (x) = x * y let f x = - let y = 0 in - fun_name y x + 3 |}] -;; - -let%expect_test "extract function with local module" = - extract_function_test - {| -let f x = - let module M = struct - let y = 0 - end in - $(x * M.y)$ + 3 -|}; - [%expect {||}] -;; - -(* TODO: This extraction shouldn't be allowed. *) -let%expect_test "extract function with local exception" = - extract_function_test - {| -let f x = - let exception Local in - $raise Local$ -|}; - [%expect - {| - let fun_name () = raise Local - - let f x = - let exception Local in - fun_name () |}] + let y = 0 in + fun_name1 y x + 3 + |}] ;; let%expect_test "extract function with shadowed parameter" = - extract_function_test + extract_test {| let x = 0 let f x = $x + 1$ @@ -97,13 +55,13 @@ let f x = $x + 1$ [%expect {| let x = 0 - let fun_name x = x + 1 - - let f x = fun_name x |}] + let fun_name1 (x) = x + 1 + let f x = fun_name1 x + |}] ;; let%expect_test "extract function with bound variable" = - extract_function_test + extract_test {| let x = 0 let y = 1 @@ -113,55 +71,69 @@ let f x = $x + y$ {| let x = 0 let y = 1 - let fun_name x = x + y - - let f x = fun_name x |}] + let fun_name1 (x) = x + y + let f x = fun_name1 x + |}] ;; let%expect_test "extract higher order function" = - extract_function_test + extract_test {| let f x = $List.map (fun y -> y + 1) x$ |}; [%expect {| - let fun_name x = List.map (fun y -> y + 1) x - + let fun_name1 (x) = List.map (fun y -> y + 1) x let f x = - fun_name x |}] + fun_name1 x + |}] ;; let%expect_test "extract higher order function" = - extract_function_test + extract_test {| let f y = $List.map (fun y -> y + 1) y$ |}; [%expect {| - let fun_name y = List.map (fun y -> y + 1) y - + let fun_name1 (y) = List.map (fun y -> y + 1) y let f y = - fun_name y |}] + fun_name1 y + |}] ;; let%expect_test "extract higher order function" = - extract_function_test + extract_test {| let f y = - $List.map (fun y -> y + 1) y$ +$List.map (fun y -> y + 1) y$ |}; [%expect {| - let fun_name y = List.map (fun y -> y + 1) y + let fun_name1 (y) = List.map (fun y -> y + 1) y + let f y = + fun_name1 y + |}] +;; +let%expect_test "extract higher order function" = + extract_test + {| +let f y = + List.map $(fun y -> y + 1)$ y +|}; + [%expect + {| + let fun_name1 = fun y -> y + 1 let f y = - fun_name y |}] + List.map fun_name1 y + |}] ;; let%expect_test "extract inside let binding" = - extract_function_test + extract_test {| let f y = let y = y + 1 in @@ -169,23 +141,25 @@ let f y = |}; [%expect {| - let fun_name y = y + 2 - + let fun_name1 (y) = y + 2 let f y = let y = y + 1 in - fun_name y |}] + fun_name1 y + |}] ;; let%expect_test "extract free variable" = - extract_function_test + extract_test {| +let z = 0 let f () = $z + 1$ |}; [%expect {| - let fun_name () = z + 1 - + let z = 0 + let fun_name1 () = z + 1 let f () = - fun_name () |}] + fun_name1 () + |}] ;; From 1594f6801821d0c1382d896b6dbac593dc36c73d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=C3=A9o=20Arnouts?= Date: Fri, 18 Jul 2025 15:48:43 +0200 Subject: [PATCH 2/3] Replace expression extraction by the new Merlin implementation. --- ocaml-lsp-server/src/code_actions.ml | 3 +- .../src/code_actions/action_extract.ml | 219 ------------------ .../src/code_actions/action_extract.mli | 2 - .../code_actions/action_refactor_extract.ml | 59 +++++ .../code_actions/action_refactor_extract.mli | 1 + 5 files changed, 61 insertions(+), 223 deletions(-) delete mode 100644 ocaml-lsp-server/src/code_actions/action_extract.ml delete mode 100644 ocaml-lsp-server/src/code_actions/action_extract.mli create mode 100644 ocaml-lsp-server/src/code_actions/action_refactor_extract.ml create mode 100644 ocaml-lsp-server/src/code_actions/action_refactor_extract.mli diff --git a/ocaml-lsp-server/src/code_actions.ml b/ocaml-lsp-server/src/code_actions.ml index 662599eea..c1781625b 100644 --- a/ocaml-lsp-server/src/code_actions.ml +++ b/ocaml-lsp-server/src/code_actions.ml @@ -49,8 +49,7 @@ let compute_ocaml_code_actions (params : CodeActionParams.t) state doc = ; Action_mark_remove_unused.mark ; Action_mark_remove_unused.remove ; Action_inline.t - ; Action_extract.local - ; Action_extract.function_ + ; Action_refactor_extract.t ] in let batchable, non_batchable = diff --git a/ocaml-lsp-server/src/code_actions/action_extract.ml b/ocaml-lsp-server/src/code_actions/action_extract.ml deleted file mode 100644 index 7946c50f4..000000000 --- a/ocaml-lsp-server/src/code_actions/action_extract.ml +++ /dev/null @@ -1,219 +0,0 @@ -open Import -open Option.O -module H = Ocaml_parsing.Ast_helper -module Typedtree_utils = Merlin_analysis.Typedtree_utils - -let range_contains_loc range loc = - match Range.of_loc_opt loc with - | Some range' -> Range.contains range range' - | None -> false -;; - -let range_contained_by_loc range loc = - match Range.of_loc_opt loc with - | Some range' -> Range.contains range' range - | None -> false -;; - -let largest_enclosed_expression typedtree range = - let exception Found of Typedtree.expression in - let module I = Ocaml_typing.Tast_iterator in - let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = - if range_contains_loc range expr.exp_loc - then raise (Found expr) - else I.default_iterator.expr iter expr - in - let iterator = { I.default_iterator with expr = expr_iter } in - try - iterator.structure iterator typedtree; - None - with - | Found e -> Some e -;; - -let enclosing_structure_item typedtree range = - let exception Found of Typedtree.structure_item in - let module I = Ocaml_typing.Tast_iterator in - let structure_item_iter (iter : I.iterator) (item : Typedtree.structure_item) = - if range_contained_by_loc range item.str_loc - then ( - match item.str_desc with - | Tstr_value _ -> raise (Found item) - | _ -> I.default_iterator.structure_item iter item) - in - let iterator = { I.default_iterator with structure_item = structure_item_iter } in - try - iterator.structure iterator typedtree; - None - with - | Found e -> Some e -;; - -let tightest_enclosing_binder_position typedtree range = - let exception Found of Position.t in - let module I = Ocaml_typing.Tast_iterator in - let found_loc loc = - Position.of_lexical_position loc |> Option.iter ~f:(fun p -> raise (Found p)) - in - let found_if_expr_contains (expr : Typedtree.expression) = - let loc = expr.exp_loc in - if range_contained_by_loc range loc then found_loc loc.loc_start - in - let found_if_case_contains cases = - List.iter cases ~f:(fun (case : _ Typedtree.case) -> - found_if_expr_contains case.c_rhs) - in - let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = - if range_contained_by_loc range expr.exp_loc - then ( - I.default_iterator.expr iter expr; - match expr.exp_desc with - | Texp_let (_, _, body) - | Texp_while (_, body) - | Texp_for (_, _, _, _, _, body) - | Texp_letmodule (_, _, _, _, body) - | Texp_letexception (_, body) - | Texp_open (_, body) -> found_if_expr_contains body - | Texp_letop { body; _ } -> found_if_case_contains [ body ] - | Texp_function (_, Tfunction_cases { cases; _ }) -> found_if_case_contains cases - | Texp_match _ -> - let m = Typedtree_utils.texp_match_of_expr expr |> Option.value_exn in - found_if_case_contains m.computation_cases - | Texp_try _ -> - let t = Typedtree_utils.texp_try_of_expr expr |> Option.value_exn in - found_if_case_contains t.value_cases - | _ -> ()) - in - let structure_item_iter (iter : I.iterator) (item : Typedtree.structure_item) = - if range_contained_by_loc range item.str_loc - then ( - I.default_iterator.structure_item iter item; - match item.str_desc with - | Tstr_value (_, bindings) -> - List.iter bindings ~f:(fun (binding : Typedtree.value_binding) -> - found_if_expr_contains binding.vb_expr) - | _ -> ()) - in - let iterator = - { I.default_iterator with expr = expr_iter; structure_item = structure_item_iter } - in - try - iterator.structure iterator typedtree; - None - with - | Found e -> Some e -;; - -module LongidentSet = Set.Make (struct - type t = Longident.t - - let compare = compare - end) - -(** [free expr] returns the free variables in [expr]. *) -let free (expr : Typedtree.expression) = - let module I = Ocaml_typing.Tast_iterator in - let idents = ref [] in - let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = - match expr.exp_desc with - | Texp_ident (path, { txt = ident; _ }, _) -> idents := (ident, path) :: !idents - | _ -> - I.default_iterator.expr iter expr; - (* if a variable was bound but is no longer, it must be associated with a - binder inside the expression *) - idents - := List.filter !idents ~f:(fun (ident, path) -> - match Env.find_value_by_name ident expr.exp_env with - | path', _ -> Path.same path path' - | exception Not_found -> false) - in - let iter = { I.default_iterator with expr = expr_iter } in - iter.expr iter expr; - !idents -;; - -let must_pass expr env = - List.filter (free expr) ~f:(fun (ident, path) -> - match Env.find_value_by_name ident env with - | path', _ -> - (* new environment binds ident to a different path than the old one *) - not (Path.same path path') - | exception Not_found -> true) - |> List.map ~f:fst -;; - -let extract_local doc typedtree range = - let* to_extract = largest_enclosed_expression typedtree range in - let* extract_range = Range.of_loc_opt to_extract.exp_loc in - let* edit_pos = tightest_enclosing_binder_position typedtree range in - let new_name = "var_name" in - let* local_text = Document.substring doc extract_range in - let newText = sprintf "let %s = %s in\n" new_name local_text in - let insert_range = { Range.start = edit_pos; end_ = edit_pos } in - Some - [ TextEdit.create ~newText ~range:insert_range - ; TextEdit.create ~newText:new_name ~range:extract_range - ] -;; - -let extract_function doc typedtree range = - let* to_extract = largest_enclosed_expression typedtree range in - let* extract_range = Range.of_loc_opt to_extract.exp_loc in - let* parent_item = enclosing_structure_item typedtree range in - let* edit_pos = Position.of_lexical_position parent_item.str_loc.loc_start in - let new_name = "fun_name" in - let* args_str = - let free_vars = must_pass to_extract parent_item.str_env in - let+ args = - List.map free_vars ~f:(function - | Longident.Lident id -> Some id - | _ -> None) - |> Option.List.all - in - let s = String.concat ~sep:" " args in - if String.is_empty s then "()" else s - in - let* func_text = Document.substring doc extract_range in - let new_function = sprintf "let %s %s = %s\n\n" new_name args_str func_text in - let new_call = sprintf "%s %s" new_name args_str in - let insert_range = { Range.start = edit_pos; end_ = edit_pos } in - Some - [ TextEdit.create ~newText:new_function ~range:insert_range - ; TextEdit.create ~newText:new_call ~range:extract_range - ] -;; - -let run_extract_local pipeline doc (params : CodeActionParams.t) = - let typer = Mpipeline.typer_result pipeline in - let* typedtree = - match Mtyper.get_typedtree typer with - | `Interface _ -> None - | `Implementation x -> Some x - in - let+ edits = extract_local doc typedtree params.range in - CodeAction.create - ~title:"Extract local" - ~kind:CodeActionKind.RefactorExtract - ~edit:(Document.edit doc edits) - ~isPreferred:false - () -;; - -let run_extract_function pipeline doc (params : CodeActionParams.t) = - let typer = Mpipeline.typer_result pipeline in - let* typedtree = - match Mtyper.get_typedtree typer with - | `Interface _ -> None - | `Implementation x -> Some x - in - let+ edits = extract_function doc typedtree params.range in - CodeAction.create - ~title:"Extract function" - ~kind:CodeActionKind.RefactorExtract - ~edit:(Document.edit doc edits) - ~isPreferred:false - () -;; - -let local = Code_action.batchable RefactorExtract run_extract_local -let function_ = Code_action.batchable RefactorExtract run_extract_function diff --git a/ocaml-lsp-server/src/code_actions/action_extract.mli b/ocaml-lsp-server/src/code_actions/action_extract.mli deleted file mode 100644 index 4ceb52ebd..000000000 --- a/ocaml-lsp-server/src/code_actions/action_extract.mli +++ /dev/null @@ -1,2 +0,0 @@ -val local : Code_action.t -val function_ : Code_action.t diff --git a/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml b/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml new file mode 100644 index 000000000..a7cdbad10 --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml @@ -0,0 +1,59 @@ +open Import + +let action_kind = "refactor-extract (extract an area into a fresh let binding)" + +let make_edit params doc { Query_protocol.loc; content; selection_range = _ } = + let uri = params.CodeActionParams.textDocument.uri in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create ~uri ~version:(Document.version doc) () + in + let textedit = TextEdit.create ~newText:content ~range:(Range.of_loc loc) in + let edit = TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit textedit ] in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () +;; + +let dispatch_command pipeline doc ~start ~stop = + let buffer = Document.source doc in + let command = Query_protocol.Refactor_extract_region (start, stop, None, buffer) in + Query_commands.dispatch pipeline command +;; + +let code_action doc (params : CodeActionParams.t) = + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None + | `Merlin merlin -> + let start = Position.logical params.range.Range.start in + let stop = Position.logical params.range.Range.end_ in + Document.Merlin.with_pipeline_exn ~name:"refactor" merlin (fun pipeline -> + let typer = Mpipeline.typer_result pipeline in + let typedtree = Mtyper.get_typedtree typer in + match typedtree with + | `Interface _ -> None + | `Implementation structure -> + let enclosing = + Mbrowse.enclosing + (Mpipeline.get_lexing_pos pipeline start) + [ Mbrowse.of_typedtree typedtree ] + in + if + Merlin_analysis.Refactor_extract_region.is_region_extractable + ~start:(Mpipeline.get_lexing_pos pipeline start) + ~stop:(Mpipeline.get_lexing_pos pipeline stop) + enclosing + structure + then ( + let substitution = dispatch_command pipeline doc ~start ~stop in + let edit = make_edit params doc substitution in + let code_action = + CodeAction.create + ~title:"Extract expression" + ~kind:(CodeActionKind.Other action_kind) + ~edit + () + in + Some code_action) + else None) +;; + +let t = Code_action.non_batchable (Other action_kind) code_action diff --git a/ocaml-lsp-server/src/code_actions/action_refactor_extract.mli b/ocaml-lsp-server/src/code_actions/action_refactor_extract.mli new file mode 100644 index 000000000..0caac27b3 --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_refactor_extract.mli @@ -0,0 +1 @@ +val t : Code_action.t From 80c3453241b1d4fd15d5fda505fa985967c75254 Mon Sep 17 00:00:00 2001 From: Tim-ats-d Date: Thu, 24 Jul 2025 16:20:01 +0200 Subject: [PATCH 3/3] Adapt to Merlin fix. --- ocaml-lsp-server/src/code_actions/action_refactor_extract.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml b/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml index a7cdbad10..00f8baf4b 100644 --- a/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml +++ b/ocaml-lsp-server/src/code_actions/action_refactor_extract.ml @@ -34,14 +34,13 @@ let code_action doc (params : CodeActionParams.t) = let enclosing = Mbrowse.enclosing (Mpipeline.get_lexing_pos pipeline start) - [ Mbrowse.of_typedtree typedtree ] + [ Mbrowse.of_structure structure ] in if Merlin_analysis.Refactor_extract_region.is_region_extractable ~start:(Mpipeline.get_lexing_pos pipeline start) ~stop:(Mpipeline.get_lexing_pos pipeline stop) enclosing - structure then ( let substitution = dispatch_command pipeline doc ~start ~stop in let edit = make_edit params doc substitution in