From 431cc2153e1f947526778a0ef0c35695a6b55f9a Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Fri, 26 Aug 2022 16:35:51 -0400 Subject: [PATCH 01/39] start work on inline action --- .../src/code_actions/action_inline.ml | 104 ++++++++++++++++++ ocaml-lsp-server/src/ocaml_lsp_server.ml | 1 + 2 files changed, 105 insertions(+) create mode 100644 ocaml-lsp-server/src/code_actions/action_inline.ml diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml new file mode 100644 index 000000000..fcddc8c7e --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -0,0 +1,104 @@ +open Import + +let action_title = "Inline" + +let log str = + let ch = + open_out_gen [ Open_wronly; Open_append ] 0o744 "/home/feser/ocamllsp.log" + in + output_string ch str; + flush ch; + close_out ch + +type inline_task = + { ident : Ident.t + ; body : Typedtree.expression (** the expression to inline *) + ; context : Typedtree.expression (** where to perform inlining *) + } + +let find_inline_task pipeline pos = + let contains loc pos = + match Position.compare_inclusion pos (Range.of_loc loc) with + | `Outside _ -> false + | `Inside -> true + in + + (* Find most enclosing nonrecursive let binding *) + let browse = + Mpipeline.typer_result pipeline + |> Mtyper.get_typedtree |> Mbrowse.of_typedtree + in + + Mbrowse.enclosing + (Mpipeline.get_lexing_pos pipeline (Position.logical pos)) + [ browse ] + |> List.find_map ~f:(function + | ( _ + , Browse_raw.Expression + { exp_desc = + Texp_let + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (id, s); _ } + ; vb_expr + ; _ + } + ] + , rhs ) + ; _ + } ) + when contains s.loc pos -> + Some { ident = id; body = vb_expr; context = rhs } + | _ -> None) + +let iter_ident_locs id expr k = + let expr_iter iter (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (Pident id', { loc; _ }, _) when Ident.same id id' -> k loc + | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr + in + let iterator = + { Ocaml_typing.Tast_iterator.default_iterator with expr = expr_iter } + in + iterator.expr iterator expr + +let iter_inline_edits task k = + iter_ident_locs task.ident task.context (fun loc -> + let textedit = TextEdit.create ~newText:"??" ~range:(Range.of_loc loc) in + k textedit) + +module Test = struct + let f x y = x + y + + let g y = f y y + + let h g x = g x + + let j x = h g x +end + +let code_action doc (params : CodeActionParams.t) = + let open Fiber.O in + let+ m_inline_task = + Document.with_pipeline_exn doc (fun pipeline -> + find_inline_task pipeline params.range.start) + in + Option.map m_inline_task ~f:(fun task -> + let edits = Queue.create () in + iter_inline_edits task (Queue.push edits); + + let edit = + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri ~version () + in + let edit = + TextDocumentEdit.create ~textDocument + ~edits:(Queue.to_list edits |> List.map ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () + in + CodeAction.create ~title:action_title ~kind:CodeActionKind.RefactorInline + ~edit ~isPreferred:false ()) + +let t = { Code_action.kind = RefactorInline; run = code_action } diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index e1ffcf752..21168fff8 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -38,6 +38,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : ; Action_refactor_open.unqualify ; Action_refactor_open.qualify ; Action_add_rec.t + ; Action_inline.t ] |> List.sort_uniq ~compare:Poly.compare in From e2bbaf38b2ae5007c070b30b9736cb8c0187762d Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 30 Aug 2022 11:01:09 -0400 Subject: [PATCH 02/39] basic inlining works --- ocaml-lsp-server/src/code_actions.ml | 4 ++-- .../src/code_actions/action_inline.ml | 19 ++++++++++++++++--- ocaml-lsp-server/src/ocaml_lsp_server.ml | 13 +++++++------ 3 files changed, 25 insertions(+), 11 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions.ml b/ocaml-lsp-server/src/code_actions.ml index 2b5785ce3..98a2d535c 100644 --- a/ocaml-lsp-server/src/code_actions.ml +++ b/ocaml-lsp-server/src/code_actions.ml @@ -82,14 +82,14 @@ let compute server (params : CodeActionParams.t) = Fiber.parallel_map ~f:code_action [ Action_destruct.t state - ; Action_inferred_intf.t state - ; Action_type_annotate.t + ; Action_inferred_intf.t state (* ; Action_type_annotate.t *) ; Action_construct.t ; Action_refactor_open.unqualify ; Action_refactor_open.qualify ; Action_add_rec.t ; Action_mark_remove_unused.mark ; Action_mark_remove_unused.remove + ; Action_inline.t ] in List.concat diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index fcddc8c7e..40a9d5c9a 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -61,9 +61,18 @@ let iter_ident_locs id expr k = in iterator.expr iterator expr -let iter_inline_edits task k = +(** Iterate over the inlining edits, one for each occurrence of the bound + variable. *) +let iter_inline_edits task _doc k = + let newText = + Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression + (Ocaml_typing.Untypeast.untype_expression task.body) + (* let start = task.body.exp_loc.loc_start.pos_cnum in *) + (* let end_ = task.body.exp_loc.loc_end.pos_cnum in *) + (* "(" ^ String.sub (Document.text doc) ~pos:start ~len:(end_ - start) ^ ")" *) + in iter_ident_locs task.ident task.context (fun loc -> - let textedit = TextEdit.create ~newText:"??" ~range:(Range.of_loc loc) in + let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in k textedit) module Test = struct @@ -74,6 +83,10 @@ module Test = struct let h g x = g x let j x = h g x + + let test () = + let y x = x + 1 in + y 0 + 2 end let code_action doc (params : CodeActionParams.t) = @@ -84,7 +97,7 @@ let code_action doc (params : CodeActionParams.t) = in Option.map m_inline_task ~f:(fun task -> let edits = Queue.create () in - iter_inline_edits task (Queue.push edits); + iter_inline_edits task doc (Queue.push edits); let edit = let version = Document.version doc in diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index 21168fff8..46db5a4b5 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -33,12 +33,13 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : Action_inferred_intf.kind :: Action_destruct.kind :: List.map ~f:(fun (c : Code_action.t) -> c.kind) - [ Action_type_annotate.t - ; Action_construct.t - ; Action_refactor_open.unqualify - ; Action_refactor_open.qualify - ; Action_add_rec.t - ; Action_inline.t + [ (* Action_type_annotate.t *) + (* ; Action_construct.t *) + (* ; Action_refactor_open.unqualify *) + (* ; Action_refactor_open.qualify *) + (* ; Action_add_rec.t *) + (* ; *) + Action_inline.t ] |> List.sort_uniq ~compare:Poly.compare in From 6014689d5744964f17b8b4373cf0b02c52dcb0ae Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 30 Aug 2022 11:34:14 -0400 Subject: [PATCH 03/39] fix special case with labeled args --- .../src/code_actions/action_inline.ml | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 40a9d5c9a..db9256425 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -2,14 +2,6 @@ open Import let action_title = "Inline" -let log str = - let ch = - open_out_gen [ Open_wronly; Open_append ] 0o744 "/home/feser/ocamllsp.log" - in - output_string ch str; - flush ch; - close_out ch - type inline_task = { ident : Ident.t ; body : Typedtree.expression (** the expression to inline *) @@ -50,30 +42,38 @@ let find_inline_task pipeline pos = Some { ident = id; body = vb_expr; context = rhs } | _ -> None) -let iter_ident_locs id expr k = - let expr_iter iter (expr : Typedtree.expression) = +(** Iterator over the text edits performed by the inlining task. *) +let iter_inline_edits task k = + let newText = + Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression + (Ocaml_typing.Untypeast.untype_expression task.body) + in + + let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) + (expr : Typedtree.expression) = match expr.exp_desc with - | Texp_ident (Pident id', { loc; _ }, _) when Ident.same id id' -> k loc + | Texp_apply (func, args) -> + iter.expr iter func; + List.iter args + ~f:(fun (label, (m_arg_expr : Typedtree.expression option)) -> + match (label, m_arg_expr) with + (* handle the labeled argument shorthand `f ~x` when inlining `x` *) + | ( Asttypes.Labelled name + , Some { exp_desc = Texp_ident (Pident name', { loc; _ }, _); _ } ) + when String.equal name (Ident.name name') -> + let newText = sprintf "%s:%s" name newText in + let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in + k textedit + | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter)) + | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.ident id -> + let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in + k textedit | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr in let iterator = { Ocaml_typing.Tast_iterator.default_iterator with expr = expr_iter } in - iterator.expr iterator expr - -(** Iterate over the inlining edits, one for each occurrence of the bound - variable. *) -let iter_inline_edits task _doc k = - let newText = - Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression - (Ocaml_typing.Untypeast.untype_expression task.body) - (* let start = task.body.exp_loc.loc_start.pos_cnum in *) - (* let end_ = task.body.exp_loc.loc_end.pos_cnum in *) - (* "(" ^ String.sub (Document.text doc) ~pos:start ~len:(end_ - start) ^ ")" *) - in - iter_ident_locs task.ident task.context (fun loc -> - let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in - k textedit) + iterator.expr iterator task.context module Test = struct let f x y = x + y @@ -97,7 +97,7 @@ let code_action doc (params : CodeActionParams.t) = in Option.map m_inline_task ~f:(fun task -> let edits = Queue.create () in - iter_inline_edits task doc (Queue.push edits); + iter_inline_edits task (Queue.push edits); let edit = let version = Document.version doc in From 42b27272a23df8b1d3569a91fddbef0b9f76ed76 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 30 Aug 2022 11:47:46 -0400 Subject: [PATCH 04/39] cleanup --- ocaml-lsp-server/src/code_actions.ml | 3 ++- ocaml-lsp-server/src/code_actions/action_inline.ml | 14 -------------- ocaml-lsp-server/src/ocaml_lsp_server.ml | 13 ++++++------- 3 files changed, 8 insertions(+), 22 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions.ml b/ocaml-lsp-server/src/code_actions.ml index 98a2d535c..fb834270c 100644 --- a/ocaml-lsp-server/src/code_actions.ml +++ b/ocaml-lsp-server/src/code_actions.ml @@ -82,7 +82,8 @@ let compute server (params : CodeActionParams.t) = Fiber.parallel_map ~f:code_action [ Action_destruct.t state - ; Action_inferred_intf.t state (* ; Action_type_annotate.t *) + ; Action_inferred_intf.t state + ; Action_type_annotate.t ; Action_construct.t ; Action_refactor_open.unqualify ; Action_refactor_open.qualify diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index db9256425..9d6a5500c 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -75,20 +75,6 @@ let iter_inline_edits task k = in iterator.expr iterator task.context -module Test = struct - let f x y = x + y - - let g y = f y y - - let h g x = g x - - let j x = h g x - - let test () = - let y x = x + 1 in - y 0 + 2 -end - let code_action doc (params : CodeActionParams.t) = let open Fiber.O in let+ m_inline_task = diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index 46db5a4b5..21168fff8 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -33,13 +33,12 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : Action_inferred_intf.kind :: Action_destruct.kind :: List.map ~f:(fun (c : Code_action.t) -> c.kind) - [ (* Action_type_annotate.t *) - (* ; Action_construct.t *) - (* ; Action_refactor_open.unqualify *) - (* ; Action_refactor_open.qualify *) - (* ; Action_add_rec.t *) - (* ; *) - Action_inline.t + [ Action_type_annotate.t + ; Action_construct.t + ; Action_refactor_open.unqualify + ; Action_refactor_open.qualify + ; Action_add_rec.t + ; Action_inline.t ] |> List.sort_uniq ~compare:Poly.compare in From 3bb7c124eea4bc1930feeef5badbeec25f6110ed Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 30 Aug 2022 12:26:01 -0400 Subject: [PATCH 05/39] promote tests --- ocaml-lsp-server/test/e2e-new/start_stop.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml-lsp-server/test/e2e-new/start_stop.ml b/ocaml-lsp-server/test/e2e-new/start_stop.ml index 1997f3705..34f724f23 100644 --- a/ocaml-lsp-server/test/e2e-new/start_stop.ml +++ b/ocaml-lsp-server/test/e2e-new/start_stop.ml @@ -35,8 +35,8 @@ let%expect_test "start/stop" = "capabilities": { "codeActionProvider": { "codeActionKinds": [ - "quickfix", "construct", "destruct", "inferred_intf", - "put module name in identifiers", + "quickfix", "refactor.inline", "construct", "destruct", + "inferred_intf", "put module name in identifiers", "remove module name from identifiers", "type-annotate" ] }, From 4e4f2d1f019e12650c60da02b5d7ce9430e5d6b1 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sun, 4 Sep 2022 16:46:53 -0400 Subject: [PATCH 06/39] extract the relevant part of parsetree instead of using untypedast --- .../src/code_actions/action_inline.ml | 69 +++++++++++-------- 1 file changed, 42 insertions(+), 27 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 9d6a5500c..9f5422ed1 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -42,12 +42,29 @@ let find_inline_task pipeline pos = Some { ident = id; body = vb_expr; context = rhs } | _ -> None) -(** Iterator over the text edits performed by the inlining task. *) -let iter_inline_edits task k = - let newText = - Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression - (Ocaml_typing.Untypeast.untype_expression task.body) +let find_parsetree_loc pipeline loc k = + let expr_iter (iter : Ocaml_parsing.Ast_iterator.iterator) + (expr : Parsetree.expression) = + if expr.pexp_loc = loc then k expr + else Ocaml_parsing.Ast_iterator.default_iterator.expr iter expr + in + let iterator = + { Ocaml_parsing.Ast_iterator.default_iterator with expr = expr_iter } in + match Mpipeline.reader_parsetree pipeline with + | `Implementation s -> iterator.structure iterator s + | _ -> () + +let inlined_text pipeline task = + let ret = ref None in + find_parsetree_loc pipeline task.body.exp_loc (fun expr -> + ret := + Some (Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr)); + Option.value_exn !ret + +(** Iterator over the text edits performed by the inlining task. *) +let iter_inline_edits pipeline task k = + let newText = inlined_text pipeline task in let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) (expr : Typedtree.expression) = @@ -76,28 +93,26 @@ let iter_inline_edits task k = iterator.expr iterator task.context let code_action doc (params : CodeActionParams.t) = - let open Fiber.O in - let+ m_inline_task = - Document.with_pipeline_exn doc (fun pipeline -> - find_inline_task pipeline params.range.start) - in - Option.map m_inline_task ~f:(fun task -> - let edits = Queue.create () in - iter_inline_edits task (Queue.push edits); + Document.with_pipeline_exn doc (fun pipeline -> + let m_inline_task = find_inline_task pipeline params.range.start in + Option.map m_inline_task ~f:(fun task -> + let edits = Queue.create () in + iter_inline_edits pipeline task (Queue.push edits); - let edit = - let version = Document.version doc in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create - ~uri:params.textDocument.uri ~version () - in - let edit = - TextDocumentEdit.create ~textDocument - ~edits:(Queue.to_list edits |> List.map ~f:(fun e -> `TextEdit e)) - in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () - in - CodeAction.create ~title:action_title ~kind:CodeActionKind.RefactorInline - ~edit ~isPreferred:false ()) + let edit = + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri ~version () + in + let edit = + TextDocumentEdit.create ~textDocument + ~edits: + (Queue.to_list edits |> List.map ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () + in + CodeAction.create ~title:action_title + ~kind:CodeActionKind.RefactorInline ~edit ~isPreferred:false ())) let t = { Code_action.kind = RefactorInline; run = code_action } From 747b33c210b55ef094e93b1ea37e8d796d423a75 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sun, 4 Sep 2022 17:00:08 -0400 Subject: [PATCH 07/39] fix bug with shadowing --- ocaml-lsp-server/src/code_actions/action_inline.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 9f5422ed1..16f8cb9aa 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -76,8 +76,8 @@ let iter_inline_edits pipeline task k = match (label, m_arg_expr) with (* handle the labeled argument shorthand `f ~x` when inlining `x` *) | ( Asttypes.Labelled name - , Some { exp_desc = Texp_ident (Pident name', { loc; _ }, _); _ } ) - when String.equal name (Ident.name name') -> + , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) + when Ident.same task.ident id -> let newText = sprintf "%s:%s" name newText in let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in k textedit From d064021b499512496de6373bb4f66fe9d46c4650 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sun, 4 Sep 2022 17:01:50 -0400 Subject: [PATCH 08/39] refactor --- ocaml-lsp-server/src/code_actions/action_inline.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 16f8cb9aa..2c6616702 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -65,6 +65,9 @@ let inlined_text pipeline task = (** Iterator over the text edits performed by the inlining task. *) let iter_inline_edits pipeline task k = let newText = inlined_text pipeline task in + let make_edit newText loc = + TextEdit.create ~newText ~range:(Range.of_loc loc) + in let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) (expr : Typedtree.expression) = @@ -79,12 +82,10 @@ let iter_inline_edits pipeline task k = , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) when Ident.same task.ident id -> let newText = sprintf "%s:%s" name newText in - let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in - k textedit + k (make_edit newText loc) | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter)) | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.ident id -> - let textedit = TextEdit.create ~newText ~range:(Range.of_loc loc) in - k textedit + k (make_edit newText loc) | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr in let iterator = From f6839be1386fd6d1f0ab0087076e43e72fa0b97f Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 8 Sep 2022 15:28:08 -0400 Subject: [PATCH 09/39] address comments --- .../src/code_actions/action_inline.ml | 83 ++++++++++--------- 1 file changed, 42 insertions(+), 41 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 2c6616702..bdc8bcc96 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -3,8 +3,8 @@ open Import let action_title = "Inline" type inline_task = - { ident : Ident.t - ; body : Typedtree.expression (** the expression to inline *) + { inlined_var : Ident.t + ; inlined_expr : Typedtree.expression (** the expression to inline *) ; context : Typedtree.expression (** where to perform inlining *) } @@ -25,7 +25,7 @@ let find_inline_task pipeline pos = (Mpipeline.get_lexing_pos pipeline (Position.logical pos)) [ browse ] |> List.find_map ~f:(function - | ( _ + | ( (_ : Ocaml_typing.Env.t) , Browse_raw.Expression { exp_desc = Texp_let @@ -39,35 +39,34 @@ let find_inline_task pipeline pos = ; _ } ) when contains s.loc pos -> - Some { ident = id; body = vb_expr; context = rhs } + Some { inlined_var = id; inlined_expr = vb_expr; context = rhs } | _ -> None) let find_parsetree_loc pipeline loc k = - let expr_iter (iter : Ocaml_parsing.Ast_iterator.iterator) - (expr : Parsetree.expression) = - if expr.pexp_loc = loc then k expr - else Ocaml_parsing.Ast_iterator.default_iterator.expr iter expr + let expr_iter (iter : Ast_iterator.iterator) (expr : Parsetree.expression) = + if Loc.compare expr.pexp_loc loc = 0 then k expr + else Ast_iterator.default_iterator.expr iter expr in - let iterator = - { Ocaml_parsing.Ast_iterator.default_iterator with expr = expr_iter } - in - match Mpipeline.reader_parsetree pipeline with + let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in + match Mpipeline.ppx_parsetree pipeline with | `Implementation s -> iterator.structure iterator s - | _ -> () + | `Interface _ -> () let inlined_text pipeline task = let ret = ref None in - find_parsetree_loc pipeline task.body.exp_loc (fun expr -> + find_parsetree_loc pipeline task.inlined_expr.exp_loc (fun expr -> ret := Some (Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr)); Option.value_exn !ret (** Iterator over the text edits performed by the inlining task. *) -let iter_inline_edits pipeline task k = +let inline_edits pipeline task = let newText = inlined_text pipeline task in let make_edit newText loc = TextEdit.create ~newText ~range:(Range.of_loc loc) in + let edits = Queue.create () in + let insert_edit newText loc = Queue.push edits (make_edit newText loc) in let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) (expr : Typedtree.expression) = @@ -80,40 +79,42 @@ let iter_inline_edits pipeline task k = (* handle the labeled argument shorthand `f ~x` when inlining `x` *) | ( Asttypes.Labelled name , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) - when Ident.same task.ident id -> + when Ident.same task.inlined_var id -> let newText = sprintf "%s:%s" name newText in - k (make_edit newText loc) + insert_edit newText loc | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter)) - | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.ident id -> - k (make_edit newText loc) + | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id + -> insert_edit newText loc | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr in let iterator = { Ocaml_typing.Tast_iterator.default_iterator with expr = expr_iter } in - iterator.expr iterator task.context + iterator.expr iterator task.context; + Queue.to_list edits let code_action doc (params : CodeActionParams.t) = - Document.with_pipeline_exn doc (fun pipeline -> - let m_inline_task = find_inline_task pipeline params.range.start in - Option.map m_inline_task ~f:(fun task -> - let edits = Queue.create () in - iter_inline_edits pipeline task (Queue.push edits); - - let edit = - let version = Document.version doc in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create - ~uri:params.textDocument.uri ~version () - in - let edit = - TextDocumentEdit.create ~textDocument - ~edits: - (Queue.to_list edits |> List.map ~f:(fun e -> `TextEdit e)) - in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () - in - CodeAction.create ~title:action_title - ~kind:CodeActionKind.RefactorInline ~edit ~isPreferred:false ())) + let open Fiber.O in + let* m_edits = + Document.with_pipeline_exn doc (fun pipeline -> + find_inline_task pipeline params.range.start + |> Option.map ~f:(inline_edits pipeline)) + in + Option.map m_edits ~f:(fun edits -> + let edit = + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri ~version () + in + let edit = + TextDocumentEdit.create ~textDocument + ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () + in + CodeAction.create ~title:action_title ~kind:CodeActionKind.RefactorInline + ~edit ~isPreferred:false ()) + |> Fiber.return let t = { Code_action.kind = RefactorInline; run = code_action } From 1076d8b58d81fe620d39ca010567c3f0683b0558 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 8 Sep 2022 16:10:21 -0400 Subject: [PATCH 10/39] handle optional arguments correctly --- .../src/code_actions/action_inline.ml | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index bdc8bcc96..405faef9c 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -68,21 +68,34 @@ let inline_edits pipeline task = let edits = Queue.create () in let insert_edit newText loc = Queue.push edits (make_edit newText loc) in + let arg_iter (iter : Ocaml_typing.Tast_iterator.iterator) + (label : Asttypes.arg_label) (m_arg_expr : Typedtree.expression option) = + match (label, m_arg_expr) with + (* handle the labeled argument shorthand `f ~x` when inlining `x` *) + | ( Labelled name + , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) + (* optional arguments have a different representation *) + | ( Optional name + , Some + { exp_desc = + Texp_construct + ( _ + , _ + , [ { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ] ) + ; _ + } ) + when Ident.same task.inlined_var id -> + let newText = sprintf "%s:%s" name newText in + insert_edit newText loc + | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) + in + let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) (expr : Typedtree.expression) = match expr.exp_desc with | Texp_apply (func, args) -> iter.expr iter func; - List.iter args - ~f:(fun (label, (m_arg_expr : Typedtree.expression option)) -> - match (label, m_arg_expr) with - (* handle the labeled argument shorthand `f ~x` when inlining `x` *) - | ( Asttypes.Labelled name - , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) - when Ident.same task.inlined_var id -> - let newText = sprintf "%s:%s" name newText in - insert_edit newText loc - | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter)) + List.iter args ~f:(fun (l, e) -> arg_iter iter l e) | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id -> insert_edit newText loc | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr From 4fc1e81125ca8e4287f7c2df7ddfa50c59e4f43a Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 8 Sep 2022 16:17:40 -0400 Subject: [PATCH 11/39] fix find_parsetree_loc --- .../src/code_actions/action_inline.ml | 42 ++++++++++++------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 405faef9c..ef5051dd6 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -42,26 +42,29 @@ let find_inline_task pipeline pos = Some { inlined_var = id; inlined_expr = vb_expr; context = rhs } | _ -> None) -let find_parsetree_loc pipeline loc k = - let expr_iter (iter : Ast_iterator.iterator) (expr : Parsetree.expression) = - if Loc.compare expr.pexp_loc loc = 0 then k expr - else Ast_iterator.default_iterator.expr iter expr - in - let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in - match Mpipeline.ppx_parsetree pipeline with - | `Implementation s -> iterator.structure iterator s - | `Interface _ -> () +let find_parsetree_loc pipeline loc = + let exception Found of Parsetree.expression in + try + let expr_iter (iter : Ast_iterator.iterator) (expr : Parsetree.expression) = + if Loc.compare expr.pexp_loc loc = 0 then raise (Found expr) + else Ast_iterator.default_iterator.expr iter expr + in + let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in + (match Mpipeline.ppx_parsetree pipeline with + | `Implementation s -> iterator.structure iterator s + | `Interface _ -> ()); + None + with Found e -> Some e let inlined_text pipeline task = - let ret = ref None in - find_parsetree_loc pipeline task.inlined_expr.exp_loc (fun expr -> - ret := - Some (Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr)); - Option.value_exn !ret + let open Option.O in + let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in + Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr (** Iterator over the text edits performed by the inlining task. *) let inline_edits pipeline task = - let newText = inlined_text pipeline task in + let open Option.O in + let+ newText = inlined_text pipeline task in let make_edit newText loc = TextEdit.create ~newText ~range:(Range.of_loc loc) in @@ -111,7 +114,7 @@ let code_action doc (params : CodeActionParams.t) = let* m_edits = Document.with_pipeline_exn doc (fun pipeline -> find_inline_task pipeline params.range.start - |> Option.map ~f:(inline_edits pipeline)) + |> Option.bind ~f:(inline_edits pipeline)) in Option.map m_edits ~f:(fun edits -> let edit = @@ -130,4 +133,11 @@ let code_action doc (params : CodeActionParams.t) = ~edit ~isPreferred:false ()) |> Fiber.return +module Test = struct + let x = + let k = 0 in + let f ?(k = 1) ~j () = k + j in + f ~j:0 ~k () +end + let t = { Code_action.kind = RefactorInline; run = code_action } From 03458eeeb6b95679e7d574bdb4350ddbe1021de9 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 14:00:21 -0400 Subject: [PATCH 12/39] use parsetree from before ppx expansion --- ocaml-lsp-server/src/code_actions/action_inline.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index ef5051dd6..e9ace0c3d 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -50,7 +50,7 @@ let find_parsetree_loc pipeline loc = else Ast_iterator.default_iterator.expr iter expr in let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in - (match Mpipeline.ppx_parsetree pipeline with + (match Mpipeline.reader_parsetree pipeline with | `Implementation s -> iterator.structure iterator s | `Interface _ -> ()); None From 7b7c262b49bf90f73a81d9a58ad770b8792b174c Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 14:00:34 -0400 Subject: [PATCH 13/39] strip merlin.loc attributes --- .../src/code_actions/action_inline.ml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index e9ace0c3d..e35d99e02 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -56,9 +56,24 @@ let find_parsetree_loc pipeline loc = None with Found e -> Some e +(** [strip_attribute name e] removes all instances of the attribute called + [name] in [e]. *) +let strip_attribute attr_name expr = + let module M = Ocaml_parsing.Ast_mapper in + let expr_map (map : M.mapper) expr = + { (M.default_mapper.expr map expr) with + pexp_attributes = + List.filter expr.pexp_attributes ~f:(fun (a : Parsetree.attribute) -> + not (String.equal a.attr_name.txt attr_name)) + } + in + let mapper = { M.default_mapper with expr = expr_map } in + mapper.expr mapper expr + let inlined_text pipeline task = let open Option.O in let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in + let expr = strip_attribute "merlin.loc" expr in Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr (** Iterator over the text edits performed by the inlining task. *) From d98d249409f4cb87a88700b23d10e9697f4491d9 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 15:09:16 -0400 Subject: [PATCH 14/39] check for shadowing before inlining --- .../src/code_actions/action_inline.ml | 100 ++++++++++++++---- 1 file changed, 82 insertions(+), 18 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index e35d99e02..540d1516d 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -8,6 +8,45 @@ type inline_task = ; context : Typedtree.expression (** where to perform inlining *) } +let find_path_by_name id env = + try Some (fst (Ocaml_typing.Env.find_value_by_name id env)) + with Not_found -> None + +let check_shadowing (inlined_expr : Typedtree.expression) new_env = + let module I = Ocaml_typing.Tast_iterator in + let orig_env = inlined_expr.exp_env in + let exception Env_mismatch of (Longident.t * [ `Unbound | `Shadowed ]) in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, { txt = ident; _ }, _) -> ( + let in_orig_env = + find_path_by_name ident orig_env + |> Option.map ~f:(Path.same path) + |> Option.value ~default:false + in + if in_orig_env then + match find_path_by_name ident new_env with + | Some path' -> + if not (Path.same path path') then + raise (Env_mismatch (ident, `Shadowed)) + | None -> raise (Env_mismatch (ident, `Unbound))) + | _ -> I.default_iterator.expr iter expr + in + let iter = { I.default_iterator with expr = expr_iter } in + try + iter.expr iter inlined_expr; + Ok () + with Env_mismatch m -> Error m + +let string_of_error (ident, reason) = + let reason = + match reason with + | `Unbound -> "unbound" + | `Shadowed -> "shadowed" + in + Format.asprintf "'%a' is %s in inlining context" + Ocaml_parsing.Pprintast.longident ident reason + let find_inline_task pipeline pos = let contains loc pos = match Position.compare_inclusion pos (Range.of_loc loc) with @@ -84,9 +123,18 @@ let inline_edits pipeline task = TextEdit.create ~newText ~range:(Range.of_loc loc) in let edits = Queue.create () in + let error = ref None in + let insert_edit newText loc = Queue.push edits (make_edit newText loc) in + let not_shadowed env = + match check_shadowing task.inlined_expr env with + | Ok () -> true + | Error e -> + error := Some e; + false + in - let arg_iter (iter : Ocaml_typing.Tast_iterator.iterator) + let arg_iter env (iter : Ocaml_typing.Tast_iterator.iterator) (label : Asttypes.arg_label) (m_arg_expr : Typedtree.expression option) = match (label, m_arg_expr) with (* handle the labeled argument shorthand `f ~x` when inlining `x` *) @@ -102,7 +150,7 @@ let inline_edits pipeline task = , [ { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ] ) ; _ } ) - when Ident.same task.inlined_var id -> + when Ident.same task.inlined_var id && not_shadowed env -> let newText = sprintf "%s:%s" name newText in insert_edit newText loc | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) @@ -113,16 +161,17 @@ let inline_edits pipeline task = match expr.exp_desc with | Texp_apply (func, args) -> iter.expr iter func; - List.iter args ~f:(fun (l, e) -> arg_iter iter l e) - | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id - -> insert_edit newText loc + List.iter args ~f:(fun (l, e) -> arg_iter expr.exp_env iter l e) + | Texp_ident (Pident id, { loc; _ }, _) + when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> + insert_edit newText loc | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr in let iterator = { Ocaml_typing.Tast_iterator.default_iterator with expr = expr_iter } in iterator.expr iterator task.context; - Queue.to_list edits + (Queue.to_list edits, !error) let code_action doc (params : CodeActionParams.t) = let open Fiber.O in @@ -131,21 +180,36 @@ let code_action doc (params : CodeActionParams.t) = find_inline_task pipeline params.range.start |> Option.bind ~f:(inline_edits pipeline)) in - Option.map m_edits ~f:(fun edits -> - let edit = - let version = Document.version doc in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create - ~uri:params.textDocument.uri ~version () + Option.bind m_edits ~f:(fun (edits, m_error) -> + match (edits, m_error) with + | [], None -> None + | [], Some error -> + let _action = + CodeAction.create ~title:action_title + ~kind:CodeActionKind.RefactorInline ~isPreferred:false + ~disabled: + (CodeAction.create_disabled ~reason:(string_of_error error)) + () in + None + | _ :: _, (Some _ | None) -> let edit = - TextDocumentEdit.create ~textDocument - ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri ~version () + in + let edit = + TextDocumentEdit.create ~textDocument + ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () - in - CodeAction.create ~title:action_title ~kind:CodeActionKind.RefactorInline - ~edit ~isPreferred:false ()) + let action = + CodeAction.create ~title:action_title + ~kind:CodeActionKind.RefactorInline ~edit ~isPreferred:false () + in + Some action) |> Fiber.return module Test = struct From ad5d6cf69aafa061b76ba8c500466add096e2c46 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 15:17:15 -0400 Subject: [PATCH 15/39] refactor --- .../src/code_actions/action_inline.ml | 24 +++++++++---------- ocaml-lsp-server/src/import.ml | 1 + 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 540d1516d..0b4d726e1 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -44,8 +44,8 @@ let string_of_error (ident, reason) = | `Unbound -> "unbound" | `Shadowed -> "shadowed" in - Format.asprintf "'%a' is %s in inlining context" - Ocaml_parsing.Pprintast.longident ident reason + Format.asprintf "'%a' is %s in inlining context" Pprintast.longident ident + reason let find_inline_task pipeline pos = let contains loc pos = @@ -113,10 +113,11 @@ let inlined_text pipeline task = let open Option.O in let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in let expr = strip_attribute "merlin.loc" expr in - Format.asprintf "(%a)" Ocaml_parsing.Pprintast.expression expr + Format.asprintf "(%a)" Pprintast.expression expr (** Iterator over the text edits performed by the inlining task. *) let inline_edits pipeline task = + let module I = Ocaml_typing.Tast_iterator in let open Option.O in let+ newText = inlined_text pipeline task in let make_edit newText loc = @@ -134,8 +135,8 @@ let inline_edits pipeline task = false in - let arg_iter env (iter : Ocaml_typing.Tast_iterator.iterator) - (label : Asttypes.arg_label) (m_arg_expr : Typedtree.expression option) = + let arg_iter env (iter : I.iterator) (label : Asttypes.arg_label) + (m_arg_expr : Typedtree.expression option) = match (label, m_arg_expr) with (* handle the labeled argument shorthand `f ~x` when inlining `x` *) | ( Labelled name @@ -156,8 +157,7 @@ let inline_edits pipeline task = | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) in - let expr_iter (iter : Ocaml_typing.Tast_iterator.iterator) - (expr : Typedtree.expression) = + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = match expr.exp_desc with | Texp_apply (func, args) -> iter.expr iter func; @@ -165,11 +165,9 @@ let inline_edits pipeline task = | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> insert_edit newText loc - | _ -> Ocaml_typing.Tast_iterator.default_iterator.expr iter expr - in - let iterator = - { Ocaml_typing.Tast_iterator.default_iterator with expr = expr_iter } + | _ -> I.default_iterator.expr iter expr in + let iterator = { I.default_iterator with expr = expr_iter } in iterator.expr iterator task.context; (Queue.to_list edits, !error) @@ -184,14 +182,14 @@ let code_action doc (params : CodeActionParams.t) = match (edits, m_error) with | [], None -> None | [], Some error -> - let _action = + let action = CodeAction.create ~title:action_title ~kind:CodeActionKind.RefactorInline ~isPreferred:false ~disabled: (CodeAction.create_disabled ~reason:(string_of_error error)) () in - None + Some action | _ :: _, (Some _ | None) -> let edit = let version = Document.version doc in diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index dc3df96e2..18070b20a 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/ocaml-lsp-server/src/import.ml @@ -119,6 +119,7 @@ end module Longident = Ocaml_parsing.Longident module Parsetree = Ocaml_parsing.Parsetree module Path = Ocaml_typing.Path +module Pprintast = Ocaml_parsing.Pprintast module Typedtree = Ocaml_typing.Typedtree module Types = Ocaml_typing.Types module Warnings = Ocaml_utils.Warnings From 12ffeaf3fce9c5ea85efbe23150e712a0adbef42 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 15:17:42 -0400 Subject: [PATCH 16/39] remove test code --- ocaml-lsp-server/src/code_actions/action_inline.ml | 7 ------- 1 file changed, 7 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 0b4d726e1..b7d524378 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -210,11 +210,4 @@ let code_action doc (params : CodeActionParams.t) = Some action) |> Fiber.return -module Test = struct - let x = - let k = 0 in - let f ?(k = 1) ~j () = k + j in - f ~j:0 ~k () -end - let t = { Code_action.kind = RefactorInline; run = code_action } From 1c35310bec66efbba5f0d11c5d1b248db1dbb164 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 12 Sep 2022 16:26:01 -0400 Subject: [PATCH 17/39] formatting --- .../src/code_actions/action_inline.ml | 58 +++++++++++-------- 1 file changed, 35 insertions(+), 23 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index b7d524378..15b52c8a1 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -44,7 +44,10 @@ let string_of_error (ident, reason) = | `Unbound -> "unbound" | `Shadowed -> "shadowed" in - Format.asprintf "'%a' is %s in inlining context" Pprintast.longident ident + Format.asprintf + "'%a' is %s in inlining context" + Pprintast.longident + ident reason let find_inline_task pipeline pos = @@ -64,22 +67,22 @@ let find_inline_task pipeline pos = (Mpipeline.get_lexing_pos pipeline (Position.logical pos)) [ browse ] |> List.find_map ~f:(function - | ( (_ : Ocaml_typing.Env.t) - , Browse_raw.Expression - { exp_desc = - Texp_let - ( Nonrecursive - , [ { vb_pat = { pat_desc = Tpat_var (id, s); _ } - ; vb_expr - ; _ - } - ] - , rhs ) - ; _ - } ) - when contains s.loc pos -> - Some { inlined_var = id; inlined_expr = vb_expr; context = rhs } - | _ -> None) + | ( (_ : Ocaml_typing.Env.t) + , Browse_raw.Expression + { exp_desc = + Texp_let + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (id, s); _ } + ; vb_expr + ; _ + } + ] + , rhs ) + ; _ + } ) + when contains s.loc pos -> + Some { inlined_var = id; inlined_expr = vb_expr; context = rhs } + | _ -> None) let find_parsetree_loc pipeline loc = let exception Found of Parsetree.expression in @@ -183,8 +186,10 @@ let code_action doc (params : CodeActionParams.t) = | [], None -> None | [], Some error -> let action = - CodeAction.create ~title:action_title - ~kind:CodeActionKind.RefactorInline ~isPreferred:false + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~isPreferred:false ~disabled: (CodeAction.create_disabled ~reason:(string_of_error error)) () @@ -195,17 +200,24 @@ let code_action doc (params : CodeActionParams.t) = let version = Document.version doc in let textDocument = OptionalVersionedTextDocumentIdentifier.create - ~uri:params.textDocument.uri ~version () + ~uri:params.textDocument.uri + ~version + () in let edit = - TextDocumentEdit.create ~textDocument + TextDocumentEdit.create + ~textDocument ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) in WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () in let action = - CodeAction.create ~title:action_title - ~kind:CodeActionKind.RefactorInline ~edit ~isPreferred:false () + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~edit + ~isPreferred:false + () in Some action) |> Fiber.return From 302e1a2d300e0f44cdd9a662cbc06cc358ea6daa Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 15 Sep 2022 10:32:41 -0400 Subject: [PATCH 18/39] fix incorrect comment --- ocaml-lsp-server/src/code_actions/action_inline.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 15b52c8a1..bda6627c4 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -118,7 +118,6 @@ let inlined_text pipeline task = let expr = strip_attribute "merlin.loc" expr in Format.asprintf "(%a)" Pprintast.expression expr -(** Iterator over the text edits performed by the inlining task. *) let inline_edits pipeline task = let module I = Ocaml_typing.Tast_iterator in let open Option.O in From 2fe33565da1e03d9405dc120887a41e83b3e3578 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 15 Sep 2022 20:15:54 -0400 Subject: [PATCH 19/39] perform beta reduction after inlining function --- .../src/code_actions/action_inline.ml | 110 +++++++++++++++++- 1 file changed, 107 insertions(+), 3 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index bda6627c4..716652405 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -112,6 +112,93 @@ let strip_attribute attr_name expr = let mapper = { M.default_mapper with expr = expr_map } in mapper.expr mapper expr +(** [uses expr path] returns the number of uses of [path] in [expr]. *) +let uses expr path = + let module I = Ocaml_typing.Tast_iterator in + let count = ref 0 in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path', _, _) when Path.same path path' -> incr count + | _ -> I.default_iterator.expr iter expr + in + let iterator = { I.default_iterator with expr = expr_iter } in + iterator.expr iterator expr; + !count + +let subst task = + let module M = Ocaml_typing.Tast_mapper in + let expr_map (map : M.mapper) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (Pident id, _, _) when Ident.same task.inlined_var id -> + task.inlined_expr + | _ -> M.default.expr map expr + in + let mapper = { M.default with expr = expr_map } in + mapper.expr mapper task.context + +(** Rough check for pure expressions. Identifiers and constants are pure. *) +let is_pure (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident _ | Texp_constant _ -> true + | _ -> false + +let rec beta_reduce (app : Typedtree.expression) = + let untype_expression = Ocaml_typing.Untypeast.untype_expression in + match app.exp_desc with + | Texp_apply + ( { exp_desc = + Texp_function + { arg_label = Nolabel + ; cases = + [ { c_lhs = { pat_desc = pat; _ } + ; c_guard = None + ; c_rhs = body + } + ] + ; _ + } + ; _ + } + , (Nolabel, Some arg) :: args' ) -> ( + let body = + if List.is_empty args' then body + else { app with exp_desc = Texp_apply (body, args') } + in + match pat with + | Tpat_any -> beta_reduce body + | Tpat_var (param, _) -> + let n_uses = uses body (Path.Pident param) in + Printf.eprintf "uses: %d\n%!" n_uses; + Out_channel.flush stderr; + if n_uses = 0 then Ocaml_typing.Untypeast.untype_expression body + else if n_uses = 1 || is_pure arg then + beta_reduce + (subst { inlined_var = param; inlined_expr = arg; context = body }) + else + (* if the parameter is used multiple times in the body, introduce a let + binding so that the parameter is evaluated only once *) + let module H = Ocaml_parsing.Ast_helper in + let body = untype_expression body in + let arg = untype_expression arg in + H.Exp.let_ + Nonrecursive + [ H.Vb.mk + (H.Pat.var { txt = Ident.name param; loc = !H.default_loc }) + arg + ] + body + | _ -> untype_expression app) + | _ -> untype_expression app + +module Test = struct + let z = + let k = 1 in + let f y = y + k in + let k = 2 in + let y = 2 in + f y +end + let inlined_text pipeline task = let open Option.O in let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in @@ -137,6 +224,7 @@ let inline_edits pipeline task = false in + (* inlining into an argument context has some special cases *) let arg_iter env (iter : I.iterator) (label : Asttypes.arg_label) (m_arg_expr : Typedtree.expression option) = match (label, m_arg_expr) with @@ -159,11 +247,27 @@ let inline_edits pipeline task = | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) in + let apply_iter env (iter : I.iterator) (func : Typedtree.expression) args = + iter.expr iter func; + List.iter args ~f:(fun (l, e) -> arg_iter env iter l e) + in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = match expr.exp_desc with - | Texp_apply (func, args) -> - iter.expr iter func; - List.iter args ~f:(fun (l, e) -> arg_iter expr.exp_env iter l e) + (* when inlining into an application context, attempt to beta reduce the + result *) + | Texp_apply ({ exp_desc = Texp_ident (Pident id, _, _); _ }, args) + when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> + let reduced_expr = + beta_reduce + { expr with exp_desc = Texp_apply (task.inlined_expr, args) } + in + let newText = + Format.asprintf "(%a)" Pprintast.expression + @@ strip_attribute "merlin.loc" reduced_expr + in + insert_edit newText expr.exp_loc + | Texp_apply (func, args) -> apply_iter expr.exp_env iter func args | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> insert_edit newText loc From 5f4c286e0d98dd30bdd9287f94bc4f0d0ed647cb Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 20 Sep 2022 13:23:05 -0400 Subject: [PATCH 20/39] continue work on beta reduction --- .../src/code_actions/action_inline.ml | 203 +++++++++++------- 1 file changed, 127 insertions(+), 76 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 716652405..b96e0b1b9 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -98,6 +98,9 @@ let find_parsetree_loc pipeline loc = None with Found e -> Some e +let find_parsetree_loc_exn pipeline loc = + Option.value_exn (find_parsetree_loc pipeline loc) + (** [strip_attribute name e] removes all instances of the attribute called [name] in [e]. *) let strip_attribute attr_name expr = @@ -112,91 +115,139 @@ let strip_attribute attr_name expr = let mapper = { M.default_mapper with expr = expr_map } in mapper.expr mapper expr -(** [uses expr path] returns the number of uses of [path] in [expr]. *) -let uses expr path = - let module I = Ocaml_typing.Tast_iterator in - let count = ref 0 in - let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = - match expr.exp_desc with - | Texp_ident (path', _, _) when Path.same path path' -> incr count - | _ -> I.default_iterator.expr iter expr - in - let iterator = { I.default_iterator with expr = expr_iter } in - iterator.expr iterator expr; - !count +module Uses = struct + type t = int Path.Map.t -let subst task = - let module M = Ocaml_typing.Tast_mapper in - let expr_map (map : M.mapper) (expr : Typedtree.expression) = - match expr.exp_desc with - | Texp_ident (Pident id, _, _) when Ident.same task.inlined_var id -> - task.inlined_expr - | _ -> M.default.expr map expr + let find m k = Path.Map.find k m + + let of_typedtree (expr : Typedtree.expression) = + let module I = Ocaml_typing.Tast_iterator in + let uses = ref Path.Map.empty in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, _, _) -> + uses := + Path.Map.update + path + (function + | Some c -> Some (c + 1) + | None -> Some 1) + !uses + | _ -> I.default_iterator.expr iter expr + in + let iterator = { I.default_iterator with expr = expr_iter } in + iterator.expr iterator expr; + !uses +end + +module Paths = struct + module Location_map = Map.Make (struct + include Loc + + let compare x x' = Ordering.of_int (compare x x') + + let position_to_dyn (pos : Lexing.position) = + Dyn.Record + [ ("pos_fname", Dyn.String pos.pos_fname) + ; ("pos_lnum", Dyn.Int pos.pos_lnum) + ; ("pos_bol", Dyn.Int pos.pos_bol) + ; ("pos_cnum", Dyn.Int pos.pos_cnum) + ] + + let to_dyn loc = + Dyn.Record + [ ("loc_start", position_to_dyn loc.loc_start) + ; ("loc_end", position_to_dyn loc.loc_end) + ; ("loc_ghost", Dyn.Bool loc.loc_ghost) + ] + end) + + type t = Path.t Location_map.t + + let find = Location_map.find + + let of_typedtree (expr : Typedtree.expression) = + let module I = Ocaml_typing.Tast_iterator in + let paths = ref Location_map.empty in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, { loc; _ }, _) -> + paths := Location_map.set !paths loc path + | _ -> I.default_iterator.expr iter expr + in + let iterator = { I.default_iterator with expr = expr_iter } in + iterator.expr iterator expr; + !paths + + let same_path ps l l' = + match (find ps l, find ps l') with + | Some p, Some p' -> Path.same p p' + | _ -> false +end + +let subst same lhs var rhs = + let module M = Ocaml_parsing.Ast_mapper in + let expr_map (map : M.mapper) (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_ident id when same var id -> lhs + | _ -> M.default_mapper.expr map expr in - let mapper = { M.default with expr = expr_map } in - mapper.expr mapper task.context + let mapper = { M.default_mapper with expr = expr_map } in + mapper.expr mapper rhs (** Rough check for pure expressions. Identifiers and constants are pure. *) -let is_pure (expr : Typedtree.expression) = - match expr.exp_desc with - | Texp_ident _ | Texp_constant _ -> true +let rec is_pure (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_ident _ | Pexp_constant _ -> true + | Pexp_field (lhs, _) -> is_pure lhs | _ -> false -let rec beta_reduce (app : Typedtree.expression) = - let untype_expression = Ocaml_typing.Untypeast.untype_expression in - match app.exp_desc with - | Texp_apply - ( { exp_desc = - Texp_function - { arg_label = Nolabel - ; cases = - [ { c_lhs = { pat_desc = pat; _ } - ; c_guard = None - ; c_rhs = body - } - ] - ; _ - } - ; _ - } - , (Nolabel, Some arg) :: args' ) -> ( - let body = - if List.is_empty args' then body - else { app with exp_desc = Texp_apply (body, args') } - in - match pat with - | Tpat_any -> beta_reduce body - | Tpat_var (param, _) -> - let n_uses = uses body (Path.Pident param) in - Printf.eprintf "uses: %d\n%!" n_uses; - Out_channel.flush stderr; - if n_uses = 0 then Ocaml_typing.Untypeast.untype_expression body - else if n_uses = 1 || is_pure arg then - beta_reduce - (subst { inlined_var = param; inlined_expr = arg; context = body }) - else - (* if the parameter is used multiple times in the body, introduce a let - binding so that the parameter is evaluated only once *) - let module H = Ocaml_parsing.Ast_helper in - let body = untype_expression body in - let arg = untype_expression arg in - H.Exp.let_ - Nonrecursive - [ H.Vb.mk - (H.Pat.var { txt = Ident.name param; loc = !H.default_loc }) - arg - ] - body - | _ -> untype_expression app) - | _ -> untype_expression app +let rec beta_reduce (uses : Uses.t) (paths : Paths.t) + (app : Parsetree.expression) = + let module H = Ocaml_parsing.Ast_helper in + match app.pexp_desc with + | Pexp_apply + ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ } + , (Nolabel, arg) :: args' ) -> ( + let body = if List.is_empty args' then body else H.Exp.apply body args' in + match pat.ppat_desc with + | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) -> + beta_reduce uses paths body + | Ppat_var param -> ( + let open Option.O in + let m_uses = + let+ path = Paths.find paths param.loc in + Uses.find uses path + in + match m_uses with + | Some 0 -> beta_reduce uses paths body + | Some 1 -> + beta_reduce uses paths (subst (Paths.same_path paths) arg param body) + | Some _ | None -> + if is_pure arg then + beta_reduce uses paths (subst (Paths.same_path paths) arg param body) + else + (* if the parameter is used multiple times in the body, introduce a + let binding so that the parameter is evaluated only once *) + H.Exp.let_ + Nonrecursive + [ H.Vb.mk pat arg ] + (beta_reduce uses paths body)) + | _ -> + H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body)) + | _ -> app + +let rec beta_reduce (app : Typedtree.expression) (p_app : Parsetree.expression) + = + assert false module Test = struct + type t = { x : int } + let z = - let k = 1 in - let f y = y + k in - let k = 2 in - let y = 2 in - f y + let f y = [%yojson_of: int] y in + let y = { x = 0 } in + f y.x end let inlined_text pipeline task = From d27de8d2062261a40fce0922bbde2a5bab915747 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 20 Sep 2022 13:32:50 -0400 Subject: [PATCH 21/39] early exit from search for inline source --- .../src/code_actions/action_inline.ml | 24 +++++++++++++------ 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index bda6627c4..b1a59754a 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -50,6 +50,14 @@ let string_of_error (ident, reason) = ident reason +let rec find_map_until ~f = function + | [] -> None + | x :: xs -> ( + match f x with + | `Return x' -> Some x' + | `Skip -> find_map_until ~f xs + | `Done -> None) + let find_inline_task pipeline pos = let contains loc pos = match Position.compare_inclusion pos (Range.of_loc loc) with @@ -66,9 +74,10 @@ let find_inline_task pipeline pos = Mbrowse.enclosing (Mpipeline.get_lexing_pos pipeline (Position.logical pos)) [ browse ] - |> List.find_map ~f:(function - | ( (_ : Ocaml_typing.Env.t) - , Browse_raw.Expression + |> find_map_until ~f:(fun (_, expr) -> + if contains (Mbrowse.node_loc expr) pos then + match expr with + | Browse_raw.Expression { exp_desc = Texp_let ( Nonrecursive @@ -79,10 +88,11 @@ let find_inline_task pipeline pos = ] , rhs ) ; _ - } ) - when contains s.loc pos -> - Some { inlined_var = id; inlined_expr = vb_expr; context = rhs } - | _ -> None) + } + when contains s.loc pos -> + `Return { inlined_var = id; inlined_expr = vb_expr; context = rhs } + | _ -> `Skip + else `Done) let find_parsetree_loc pipeline loc = let exception Found of Parsetree.expression in From 32bc3e44b1366fbaebb2e9857bb11135f69c66b9 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 20 Sep 2022 14:57:47 -0400 Subject: [PATCH 22/39] basic beta reduction now works on pre-ppx parsetree --- .../src/code_actions/action_inline.ml | 58 ++++++++++++------- 1 file changed, 38 insertions(+), 20 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 5128c3dbe..c1be43c43 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -1,4 +1,5 @@ open Import +module H = Ocaml_parsing.Ast_helper let action_title = "Inline" @@ -128,7 +129,7 @@ let strip_attribute attr_name expr = module Uses = struct type t = int Path.Map.t - let find m k = Path.Map.find k m + let find m k = Path.Map.find_opt k m let of_typedtree (expr : Typedtree.expression) = let module I = Ocaml_typing.Tast_iterator in @@ -185,7 +186,16 @@ module Paths = struct paths := Location_map.set !paths loc path | _ -> I.default_iterator.expr iter expr in - let iterator = { I.default_iterator with expr = expr_iter } in + let pat_iter (type k) (iter : I.iterator) + (pat : k Typedtree.general_pattern) = + match pat.pat_desc with + | Tpat_var (id, { loc; _ }) -> + paths := Location_map.set !paths loc (Pident id) + | _ -> I.default_iterator.pat iter pat + in + let iterator = + { I.default_iterator with expr = expr_iter; pat = pat_iter } + in iterator.expr iterator expr; !paths @@ -195,17 +205,18 @@ module Paths = struct | _ -> false end -let subst same lhs var rhs = +let subst same subst_expr subst_id body = let module M = Ocaml_parsing.Ast_mapper in let expr_map (map : M.mapper) (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_ident id when same var id -> lhs + | Pexp_ident id when same subst_id id -> subst_expr | _ -> M.default_mapper.expr map expr in let mapper = { M.default_mapper with expr = expr_map } in - mapper.expr mapper rhs + mapper.expr mapper body -(** Rough check for pure expressions. Identifiers and constants are pure. *) +(** Rough check for expressions that can be duplicated without duplicating any + side effects. *) let rec is_pure (expr : Parsetree.expression) = match expr.pexp_desc with | Pexp_ident _ | Pexp_constant _ -> true @@ -214,7 +225,6 @@ let rec is_pure (expr : Parsetree.expression) = let rec beta_reduce (uses : Uses.t) (paths : Paths.t) (app : Parsetree.expression) = - let module H = Ocaml_parsing.Ast_helper in match app.pexp_desc with | Pexp_apply ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ } @@ -226,16 +236,19 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) | Ppat_var param -> ( let open Option.O in let m_uses = - let+ path = Paths.find paths param.loc in + let* path = Paths.find paths param.loc in Uses.find uses path in + let same_path paths (id : _ H.with_loc) (id' : _ H.with_loc) = + Paths.same_path paths id.loc id'.loc + in match m_uses with | Some 0 -> beta_reduce uses paths body | Some 1 -> - beta_reduce uses paths (subst (Paths.same_path paths) arg param body) + beta_reduce uses paths (subst (same_path paths) arg param body) | Some _ | None -> if is_pure arg then - beta_reduce uses paths (subst (Paths.same_path paths) arg param body) + beta_reduce uses paths (subst (same_path paths) arg param body) else (* if the parameter is used multiple times in the body, introduce a let binding so that the parameter is evaluated only once *) @@ -247,15 +260,11 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body)) | _ -> app -let rec beta_reduce (app : Typedtree.expression) (p_app : Parsetree.expression) - = - assert false - module Test = struct type t = { x : int } let z = - let f y = [%yojson_of: int] y in + let f y = y + 1 in let y = { x = 0 } in f y.x end @@ -313,19 +322,28 @@ let inline_edits pipeline task = List.iter args ~f:(fun (l, e) -> arg_iter env iter l e) in + let uses = Uses.of_typedtree task.inlined_expr in + let paths = Paths.of_typedtree task.inlined_expr in + let inlined_pexpr = + find_parsetree_loc_exn pipeline task.inlined_expr.exp_loc + in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = match expr.exp_desc with (* when inlining into an application context, attempt to beta reduce the result *) - | Texp_apply ({ exp_desc = Texp_ident (Pident id, _, _); _ }, args) + | Texp_apply ({ exp_desc = Texp_ident (Pident id, _, _); _ }, _) when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> - let reduced_expr = - beta_reduce - { expr with exp_desc = Texp_apply (task.inlined_expr, args) } + let reduced_pexpr = + let app_pexpr = find_parsetree_loc_exn pipeline expr.exp_loc in + match app_pexpr.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident _; _ }, args) -> + beta_reduce uses paths (H.Exp.apply inlined_pexpr args) + | _ -> app_pexpr in let newText = Format.asprintf "(%a)" Pprintast.expression - @@ strip_attribute "merlin.loc" reduced_expr + @@ strip_attribute "merlin.loc" reduced_pexpr in insert_edit newText expr.exp_loc | Texp_apply (func, args) -> apply_iter expr.exp_env iter func args From 90b2ccb0d6ce65502d4bf16a184f7a5db285022d Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 20 Sep 2022 15:43:19 -0400 Subject: [PATCH 23/39] handle labeled arguments in beta reduce --- .../src/code_actions/action_inline.ml | 45 +++++++++++++++---- 1 file changed, 36 insertions(+), 9 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index c1be43c43..5e1599054 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -126,6 +126,7 @@ let strip_attribute attr_name expr = let mapper = { M.default_mapper with expr = expr_map } in mapper.expr mapper expr +(** Overapproximation of the number of uses of a [Path.t] in an expression. *) module Uses = struct type t = int Path.Map.t @@ -151,6 +152,8 @@ module Uses = struct !uses end +(** Mapping from [Location.t] to [Path.t]. Computed from the typedtree. Useful + for determining whether two parsetree identifiers refer to the same path. *) module Paths = struct module Location_map = Map.Make (struct include Loc @@ -223,13 +226,18 @@ let rec is_pure (expr : Parsetree.expression) = | Pexp_field (lhs, _) -> is_pure lhs | _ -> false +let rec find_map_remove ~f = function + | [] -> (None, []) + | x :: xs -> ( + match f x with + | Some x' -> (Some x', xs) + | None -> + let ret, xs' = find_map_remove ~f xs in + (ret, x :: xs')) + let rec beta_reduce (uses : Uses.t) (paths : Paths.t) (app : Parsetree.expression) = - match app.pexp_desc with - | Pexp_apply - ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ } - , (Nolabel, arg) :: args' ) -> ( - let body = if List.is_empty args' then body else H.Exp.apply body args' in + let beta_reduce_arg (pat : Parsetree.pattern) body arg = match pat.ppat_desc with | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) -> beta_reduce uses paths body @@ -257,16 +265,35 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) [ H.Vb.mk pat arg ] (beta_reduce uses paths body)) | _ -> - H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body)) + H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body) + in + let apply func args = + if List.is_empty args then func else H.Exp.apply func args + in + match app.pexp_desc with + | Pexp_apply + ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ } + , (Nolabel, arg) :: args' ) -> beta_reduce_arg pat (apply body args') arg + | Pexp_apply + ({ pexp_desc = Pexp_fun ((Labelled l as lbl), None, pat, body); _ }, args) + -> ( + let m_matching_arg, args' = + find_map_remove args ~f:(function + | Asttypes.Labelled l', e when String.(l = l') -> Some e + | _ -> None) + in + match m_matching_arg with + | Some arg -> beta_reduce_arg pat (apply body args') arg + | None -> H.Exp.fun_ lbl None pat (beta_reduce uses paths (apply body args)) + ) | _ -> app module Test = struct type t = { x : int } let z = - let f y = y + 1 in - let y = { x = 0 } in - f y.x + let f ~y ~z a = y + z + a in + f 2 ~z:0 end let inlined_text pipeline task = From 8f06e84aade5f95e67df5de05e8a57d541e4e73e Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Tue, 20 Sep 2022 19:02:49 -0400 Subject: [PATCH 24/39] fix inlining functions with constrained args --- .../src/code_actions/action_inline.ml | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 5e1599054..109879cc8 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -194,6 +194,9 @@ module Paths = struct match pat.pat_desc with | Tpat_var (id, { loc; _ }) -> paths := Location_map.set !paths loc (Pident id) + | Tpat_alias (pat, id, { loc; _ }) -> + paths := Location_map.set !paths loc (Pident id); + I.default_iterator.pat iter pat | _ -> I.default_iterator.pat iter pat in let iterator = @@ -222,8 +225,8 @@ let subst same subst_expr subst_id body = side effects. *) let rec is_pure (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_ident _ | Pexp_constant _ -> true - | Pexp_field (lhs, _) -> is_pure lhs + | Pexp_ident _ | Pexp_constant _ | Pexp_hole | Pexp_unreachable -> true + | Pexp_field (e, _) | Pexp_constraint (e, _) -> is_pure e | _ -> false let rec find_map_remove ~f = function @@ -241,7 +244,8 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) match pat.ppat_desc with | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) -> beta_reduce uses paths body - | Ppat_var param -> ( + | Ppat_var param | Ppat_constraint ({ ppat_desc = Ppat_var param; _ }, _) + -> ( let open Option.O in let m_uses = let* path = Paths.find paths param.loc in @@ -279,7 +283,7 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) -> ( let m_matching_arg, args' = find_map_remove args ~f:(function - | Asttypes.Labelled l', e when String.(l = l') -> Some e + | Asttypes.Labelled l', e when String.equal l l' -> Some e | _ -> None) in match m_matching_arg with @@ -292,8 +296,8 @@ module Test = struct type t = { x : int } let z = - let f ~y ~z a = y + z + a in - f 2 ~z:0 + let f (y : int) (z : int) a = y + z + a in + f 2 0 end let inlined_text pipeline task = @@ -344,11 +348,6 @@ let inline_edits pipeline task = | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) in - let apply_iter env (iter : I.iterator) (func : Typedtree.expression) args = - iter.expr iter func; - List.iter args ~f:(fun (l, e) -> arg_iter env iter l e) - in - let uses = Uses.of_typedtree task.inlined_expr in let paths = Paths.of_typedtree task.inlined_expr in let inlined_pexpr = @@ -373,7 +372,9 @@ let inline_edits pipeline task = @@ strip_attribute "merlin.loc" reduced_pexpr in insert_edit newText expr.exp_loc - | Texp_apply (func, args) -> apply_iter expr.exp_env iter func args + | Texp_apply (func, args) -> + iter.expr iter func; + List.iter args ~f:(fun (l, e) -> arg_iter expr.exp_env iter l e) | Texp_ident (Pident id, { loc; _ }, _) when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> insert_edit newText loc From 46daa9b7aca241df254fca298f12f26709331ba1 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Wed, 21 Sep 2022 10:27:49 -0400 Subject: [PATCH 25/39] add tests for inlining action --- .../test/e2e-new/action_inline.ml | 339 ++++++++++++++++++ ocaml-lsp-server/test/e2e-new/code_actions.ml | 91 ++--- 2 files changed, 385 insertions(+), 45 deletions(-) create mode 100644 ocaml-lsp-server/test/e2e-new/action_inline.ml diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml new file mode 100644 index 000000000..297618764 --- /dev/null +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -0,0 +1,339 @@ +open Test.Import +open Code_actions + +let find_mapi ~f l = + let rec k i = function + | [] -> None + | x :: xs -> ( + match f i x with + | Some x' -> Some x' + | None -> k (i + 1) xs) + in + k 0 l + +let parse_cursor src = + let cursor = + String.split_lines src + |> find_mapi ~f:(fun lnum line -> + match String.index line '$' with + | Some cnum -> Some (Position.create ~character:cnum ~line:lnum) + | None -> None) + |> Option.value_exn + in + ( String.filter_map src ~f:(function + | '$' -> None + | c -> Some c) + , Range.create ~start:cursor ~end_:cursor ) + +let rec take n l = + if n = 0 then [] + else + match l with + | [] -> failwith "list shorter than n" + | x :: xs -> x :: take (n - 1) xs + +let offset_of_position src (pos : Position.t) = + let line_offset = + String.split_lines src |> take pos.line + |> List.fold_left ~init:0 ~f:(fun s l -> s + String.length l) + in + line_offset + pos.line (* account for line endings *) + pos.character + +let apply_edit (edit : TextEdit.t) src = + let start_offset = offset_of_position src edit.range.start in + let end_offset = offset_of_position src edit.range.end_ in + let start = String.take src start_offset in + let end_ = String.drop src end_offset in + start ^ edit.newText ^ end_ + +let apply_inline_action src range = + let open Option.O in + let code_actions = ref None in + iter_code_actions src range (fun ca -> code_actions := Some ca); + let* m_code_actions = !code_actions in + let* code_actions = m_code_actions in + let* { documentChanges; _ } = + List.find_map code_actions ~f:(function + | `CodeAction { kind = Some RefactorInline; edit = Some edit; _ } -> + Some edit + | _ -> None) + in + let+ documentChanges in + let edits = + List.filter_map documentChanges ~f:(function + | `TextDocumentEdit e -> Some e + | _ -> None) + in + match edits with + | [] -> src + | [ { edits = [ `TextEdit e ]; _ } ] -> apply_edit e src + | _ -> failwith "expected one edit" + +let inline_test src = + let src, range = parse_cursor src in + Option.iter (apply_inline_action src range) ~f:print_string + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + x + 1 +|}; + [%expect {| + let _ = + let x = 0 in + (0) + 1 |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + f 1 +|}; + [%expect {| + let _ = + let f x = x in + (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f _ = 0 in + f 1 +|}; + [%expect {| + let _ = + let f _ = 0 in + (0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x + x in + f 1 +|}; + [%expect {| + let _ = + let f x = x + x in + (1 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x + x in + f (g 1) +|}; + [%expect + {| + let _ = + let f x = x + x in + (let x = g 1 in x + x) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x y = x + y in + f 0 +|}; + [%expect {| + let _ = + let f x y = x + y in + (fun y -> 0 + y) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x ~y = x + y in + f ~y:0 +|}; + [%expect + {| + let _ = + let f x ~y = x + y in + ((fun x ~y -> x + y) ~y:0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f ~x y = x + y in + f ~x:0 +|}; + [%expect {| + let _ = + let f ~x y = x + y in + (fun y -> 0 + y) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f ~x ~y = x + y in + f ~y:0 +|}; + [%expect + {| + let _ = + let f ~x ~y = x + y in + (fun ~x -> x + 0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x : int) = x + 1 in + f 0 +|}; + [%expect + {| + let _ = + let f (x : int) = x + 1 in + (0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (type a) (x : a) = x in + f 0 +|}; + [%expect + {| + let _ = + let f (type a) (x : a) = x in + ((fun (type a) -> fun (x : a) -> x) 0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f : int -> int = fun x -> x in + f 0 +|}; + [%expect + {| + let _ = + let f : int -> int = fun x -> x in + (0) |}] + +let%expect_test "" = + inline_test + {| +let _ = + let $f = function Some x -> x | None -> 0 in + f (Some 1) +|}; + [%expect + {| + let _ = + let f = function Some x -> x | None -> 0 in + ((function | Some x -> x | None -> 0) (Some 1)) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x as y) = y + 1 in + f 1 +|}; + [%expect + {| + let _ = + let f (x as y) = y + 1 in + (let x as y = 1 in y + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f 1 = 2 in + f 2 +|}; + [%expect + {| + let _ = + let f 1 = 2 in + (let 1 = 2 in 2) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x, y) = x + y in + f (1, 2) +|}; + [%expect + {| + let _ = + let f (x, y) = x + y in + (let (x, y) = (1, 2) in x + y) |}] + +let%expect_test "" = + inline_test + {| +type t = { x : int; y : int } +let _ = + let $f { x; y } = x + y in + f { x = 1; y = 1 } +|}; + [%expect + {| + type t = { x : int; y : int } + let _ = + let f { x; y } = x + y in + (let { x; y } = { x = 1; y = 1 } in x + y) |}] + +let%expect_test "" = + inline_test + {| +type t = { x : int; y : int } +let _ = + let $f { x; _ } = x + 1 in + f { x = 1; y = 1 } +|}; + [%expect + {| + type t = { x : int; y : int } + let _ = + let f { x; _ } = x + 1 in + (let { x;_} = { x = 1; y = 1 } in x + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = [%test] x in + f 1 +|}; + [%expect + {| + let _ = + let f x = [%test] x in + (([%test ]) 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + [%test] (f 1) +|}; + [%expect + {| + let _ = + let f x = x in + [%test] (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = (* test comment *) x in + f 1 +|}; + [%expect + {| + let _ = + let f x = (* test comment *) x in + (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + (* test comment *) f 1 +|}; + [%expect + {| + let _ = + let f x = x in + (* test comment *) (1) |}] diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 68b65c44c..292973ddd 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -1,54 +1,47 @@ open Test.Import -let%expect_test "code actions" = - let source = {ocaml| -let foo = 123 -|ocaml} in +let iter_code_actions ?(path = "foo.ml") source range k = let handler = Client.Handler.make ~on_notification:(fun _ _ -> Fiber.return ()) () in - ( Test.run ~handler @@ fun client -> - let run_client () = - let capabilities = - let window = - let showDocument = - ShowDocumentClientCapabilities.create ~support:true - in - WindowClientCapabilities.create ~showDocument () + Test.run ~handler @@ fun client -> + let run_client () = + let capabilities = + let window = + let showDocument = + ShowDocumentClientCapabilities.create ~support:true in - ClientCapabilities.create ~window () + WindowClientCapabilities.create ~showDocument () in - Client.start client (InitializeParams.create ~capabilities ()) + ClientCapabilities.create ~window () in - let run = - let* (_ : InitializeResult.t) = Client.initialized client in - let uri = DocumentUri.of_path "foo.ml" in - let* () = - let textDocument = - TextDocumentItem.create - ~uri - ~languageId:"ocaml" - ~version:0 - ~text:source - in - Client.notification - client - (TextDocumentDidOpen (DidOpenTextDocumentParams.create ~textDocument)) + Client.start client (InitializeParams.create ~capabilities ()) + in + let run = + let* (_ : InitializeResult.t) = Client.initialized client in + let uri = DocumentUri.of_path path in + let* () = + let textDocument = + TextDocumentItem.create ~uri ~languageId:"ocaml" ~version:0 ~text:source in - let+ resp = - let range = - let start = Position.create ~line:1 ~character:5 in - let end_ = Position.create ~line:1 ~character:7 in - Range.create ~start ~end_ - in - let context = CodeActionContext.create ~diagnostics:[] () in - let request = - let textDocument = TextDocumentIdentifier.create ~uri in - CodeActionParams.create ~textDocument ~range ~context () - in - Client.request client (CodeAction request) + Client.notification + client + (TextDocumentDidOpen (DidOpenTextDocumentParams.create ~textDocument)) + in + let+ resp = + let context = CodeActionContext.create ~diagnostics:[] () in + let request = + let textDocument = TextDocumentIdentifier.create ~uri in + CodeActionParams.create ~textDocument ~range ~context () in - match resp with + Client.request client (CodeAction request) + in + k resp + in + Fiber.fork_and_join_unit run_client (fun () -> run >>> Client.stop client) + +let print_code_actions ?(path = "foo.ml") source range = + iter_code_actions ~path source range (function | None -> print_endline "no code actions" | Some code_actions -> print_endline "Code actions:"; @@ -58,10 +51,18 @@ let foo = 123 | `Command command -> Command.yojson_of_t command | `CodeAction ca -> CodeAction.yojson_of_t ca in - Yojson.Safe.pretty_to_string ~std:false json |> print_endline) - in - Fiber.fork_and_join_unit run_client (fun () -> run >>> Client.stop client) - ); + Yojson.Safe.pretty_to_string ~std:false json |> print_endline)) + +let%expect_test "code actions" = + let source = {ocaml| +let foo = 123 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:7 in + Range.create ~start ~end_ + in + print_code_actions source range; [%expect {| Code actions: From 022ba6c0c80b07a3ef8dd6341794f19a31557eec Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Wed, 21 Sep 2022 13:41:09 -0400 Subject: [PATCH 26/39] start work on top level let support --- .../src/code_actions/action_inline.ml | 107 ++++++++++-------- .../test/e2e-new/action_inline.ml | 99 +++++++++++++--- 2 files changed, 146 insertions(+), 60 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 109879cc8..07fdea904 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -6,7 +6,6 @@ let action_title = "Inline" type inline_task = { inlined_var : Ident.t ; inlined_expr : Typedtree.expression (** the expression to inline *) - ; context : Typedtree.expression (** where to perform inlining *) } let find_path_by_name id env = @@ -51,49 +50,52 @@ let string_of_error (ident, reason) = ident reason -let rec find_map_until ~f = function - | [] -> None - | x :: xs -> ( - match f x with - | `Return x' -> Some x' - | `Skip -> find_map_until ~f xs - | `Done -> None) - -let find_inline_task pipeline pos = - let contains loc pos = - match Position.compare_inclusion pos (Range.of_loc loc) with - | `Outside _ -> false - | `Inside -> true - in +let contains loc pos = + match Position.compare_inclusion pos (Range.of_loc loc) with + | `Outside _ -> false + | `Inside -> true - (* Find most enclosing nonrecursive let binding *) - let browse = - Mpipeline.typer_result pipeline - |> Mtyper.get_typedtree |> Mbrowse.of_typedtree +let find_inline_task typedtree pos = + let exception Found of inline_task in + let module I = Ocaml_typing.Tast_iterator in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + if contains expr.exp_loc pos then + match expr.exp_desc with + | Texp_let + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ } + ; vb_expr = inlined_expr + ; _ + } + ] + , _ ) + when contains loc pos -> raise (Found { inlined_var; inlined_expr }) + | _ -> I.default_iterator.expr iter expr in - - Mbrowse.enclosing - (Mpipeline.get_lexing_pos pipeline (Position.logical pos)) - [ browse ] - |> find_map_until ~f:(fun (_, expr) -> - if contains (Mbrowse.node_loc expr) pos then - match expr with - | Browse_raw.Expression - { exp_desc = - Texp_let - ( Nonrecursive - , [ { vb_pat = { pat_desc = Tpat_var (id, s); _ } - ; vb_expr - ; _ - } - ] - , rhs ) - ; _ - } - when contains s.loc pos -> - `Return { inlined_var = id; inlined_expr = vb_expr; context = rhs } - | _ -> `Skip - else `Done) + let structure_item_iter (iter : I.iterator) (item : Typedtree.structure_item) + = + if contains item.str_loc pos then + match item.str_desc with + | Tstr_value + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ } + ; vb_expr = inlined_expr + ; _ + } + ] ) + when contains loc pos -> raise (Found { inlined_var; inlined_expr }) + | _ -> I.default_iterator.structure_item iter item + in + let iterator = + { I.default_iterator with + expr = expr_iter + ; structure_item = structure_item_iter + } + in + try + iterator.structure iterator typedtree; + None + with Found task -> Some task let find_parsetree_loc pipeline loc = let exception Found of Parsetree.expression in @@ -381,15 +383,28 @@ let inline_edits pipeline task = | _ -> I.default_iterator.expr iter expr in let iterator = { I.default_iterator with expr = expr_iter } in - iterator.expr iterator task.context; - (Queue.to_list edits, !error) + + let edits = + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> [] + | `Implementation structure -> + iterator.structure iterator structure; + Queue.to_list edits + in + (edits, !error) let code_action doc (params : CodeActionParams.t) = let open Fiber.O in let* m_edits = Document.with_pipeline_exn doc (fun pipeline -> - find_inline_task pipeline params.range.start - |> Option.bind ~f:(inline_edits pipeline)) + let open Option.O in + let* typedtree = + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> None + | `Implementation x -> Some x + in + let* task = find_inline_task typedtree params.range.start in + inline_edits pipeline task) in Option.bind m_edits ~f:(fun (edits, m_error) -> match (edits, m_error) with diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index 297618764..f596c2c21 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -84,6 +84,53 @@ let _ = let x = 0 in (0) + 1 |}] +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun x -> x) x +|}; + [%expect {| + let _ = + let x = 0 + 1 in + (fun x -> x) (0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun ~x -> x) ~x +|}; + [%expect + {| + let _ = + let x = 0 + 1 in + (fun ~x -> x) ~x:(0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun ?(x = 2) -> x) ~x +|}; + [%expect + {| + let _ = + let x = 0 + 1 in + (fun ?(x = 2) -> x) ~x:(0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = Some 0 in + (fun ?(x = 2) -> x) ?x +|}; + [%expect + {| + let _ = + let x = 0 + 1 in + (fun ?(x = 2) -> x) ~x:(0 + 1) |}] + let%expect_test "" = inline_test {| let _ = @@ -181,12 +228,12 @@ let _ = let $f (x : int) = x + 1 in f 0 |}; - [%expect - {| + [%expect {| let _ = let f (x : int) = x + 1 in (0 + 1) |}] +(* TODO *) let%expect_test "" = inline_test {| let _ = @@ -205,8 +252,7 @@ let _ = let $f : int -> int = fun x -> x in f 0 |}; - [%expect - {| + [%expect {| let _ = let f : int -> int = fun x -> x in (0) |}] @@ -242,12 +288,12 @@ let _ = let $f 1 = 2 in f 2 |}; - [%expect - {| + [%expect {| let _ = let f 1 = 2 in (let 1 = 2 in 2) |}] +(* TODO *) let%expect_test "" = inline_test {| let _ = @@ -260,6 +306,7 @@ let _ = let f (x, y) = x + y in (let (x, y) = (1, 2) in x + y) |}] +(* TODO *) let%expect_test "" = inline_test {| @@ -275,6 +322,7 @@ let _ = let f { x; y } = x + y in (let { x; y } = { x = 1; y = 1 } in x + y) |}] +(* TODO *) let%expect_test "" = inline_test {| @@ -296,8 +344,7 @@ let _ = let $f x = [%test] x in f 1 |}; - [%expect - {| + [%expect {| let _ = let f x = [%test] x in (([%test ]) 1) |}] @@ -308,8 +355,7 @@ let _ = let $f x = x in [%test] (f 1) |}; - [%expect - {| + [%expect {| let _ = let f x = x in [%test] (1) |}] @@ -320,8 +366,7 @@ let _ = let $f x = (* test comment *) x in f 1 |}; - [%expect - {| + [%expect {| let _ = let f x = (* test comment *) x in (1) |}] @@ -332,8 +377,34 @@ let _ = let $f x = x in (* test comment *) f 1 |}; - [%expect - {| + [%expect {| let _ = let f x = x in (* test comment *) (1) |}] + +let%expect_test "" = + inline_test {| +let $f x = x +let g y = f y +|}; + [%expect {| + let f x = x + let g y = (y) |}] + +(* TODO *) +let%expect_test "" = + inline_test + {| +module M = struct + let $f x = x + let g y = f y +end +let h = M.f +|}; + [%expect + {| + module M = struct + let f x = x + let g y = (y) + end + let h = M.f |}] From 9dcd43e7b739f8281eaa16734d8467174a182431 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Wed, 21 Sep 2022 17:39:08 -0400 Subject: [PATCH 27/39] fix bugs related to optional arguments --- .../src/code_actions/action_inline.ml | 13 ++++++++-- .../test/e2e-new/action_inline.ml | 26 ++++++++++++++++--- 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 07fdea904..b47ad383e 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -334,10 +334,13 @@ let inline_edits pipeline task = (* handle the labeled argument shorthand `f ~x` when inlining `x` *) | ( Labelled name , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) - (* optional arguments have a different representation *) + (* inlining is allowed for optional arguments that are being passed a Some + parameter, i.e. `x` may be inlined in `let x = 1 in (fun ?(x = 0) -> x) + ~x` *) | ( Optional name , Some { exp_desc = + (* construct is part of desugaring, assumed to be Some *) Texp_construct ( _ , _ @@ -347,7 +350,13 @@ let inline_edits pipeline task = when Ident.same task.inlined_var id && not_shadowed env -> let newText = sprintf "%s:%s" name newText in insert_edit newText loc - | _, m_expr -> Option.iter m_expr ~f:(iter.expr iter) + | Optional _, Some ({ exp_desc = Texp_construct _; _ } as arg_expr) -> + iter.expr iter arg_expr + (* inlining is _not_ allowed for optional arguments that are being passed an + optional parameter i.e. `x` may _not_ be inlined in `let x = Some 1 in + (fun ?(x = 0) -> x) ?x` *) + | Optional _, Some _ -> () + | _, _ -> Option.iter m_arg_expr ~f:(iter.expr iter) in let uses = Uses.of_typedtree task.inlined_expr in diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index f596c2c21..41ae31e3f 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -125,11 +125,29 @@ let _ = let $x = Some 0 in (fun ?(x = 2) -> x) ?x |}; - [%expect - {| + [%expect {| |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + (fun ~x -> x) ~x:(x + 1) +|}; + [%expect {| let _ = - let x = 0 + 1 in - (fun ?(x = 2) -> x) ~x:(0 + 1) |}] + let x = 0 in + (fun ~x -> x) ~x:((0) + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + (fun ?(x = 1) -> x) ~x:(x + 1) +|}; + [%expect {| + let _ = + let x = 0 in + (fun ?(x = 1) -> x) ~x:((0) + 1) |}] let%expect_test "" = inline_test {| From 35de9446b760643661c506ce156a1e0a45d15c96 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Wed, 21 Sep 2022 17:49:44 -0400 Subject: [PATCH 28/39] beta reduce literal tuple arguments --- .../src/code_actions/action_inline.ml | 22 +++++++++++++------ .../test/e2e-new/action_inline.ml | 22 ++++++++++++++----- 2 files changed, 32 insertions(+), 12 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index b47ad383e..ce1414d2a 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -242,7 +242,10 @@ let rec find_map_remove ~f = function let rec beta_reduce (uses : Uses.t) (paths : Paths.t) (app : Parsetree.expression) = - let beta_reduce_arg (pat : Parsetree.pattern) body arg = + let rec beta_reduce_arg (pat : Parsetree.pattern) body arg = + let default () = + H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body) + in match pat.ppat_desc with | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) -> beta_reduce uses paths body @@ -266,12 +269,17 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) else (* if the parameter is used multiple times in the body, introduce a let binding so that the parameter is evaluated only once *) - H.Exp.let_ - Nonrecursive - [ H.Vb.mk pat arg ] - (beta_reduce uses paths body)) - | _ -> - H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body) + default ()) + | Ppat_tuple pats -> ( + match arg.pexp_desc with + | Pexp_tuple args -> + List.fold_left2 + ~f:(fun body pat arg -> beta_reduce_arg pat body arg) + ~init:body + pats + args + | _ -> default ()) + | _ -> default () in let apply func args = if List.is_empty args then func else H.Exp.apply func args diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index 41ae31e3f..43c1b8b9e 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -133,7 +133,8 @@ let _ = let $x = 0 in (fun ~x -> x) ~x:(x + 1) |}; - [%expect {| + [%expect + {| let _ = let x = 0 in (fun ~x -> x) ~x:((0) + 1) |}] @@ -144,7 +145,8 @@ let _ = let $x = 0 in (fun ?(x = 1) -> x) ~x:(x + 1) |}; - [%expect {| + [%expect + {| let _ = let x = 0 in (fun ?(x = 1) -> x) ~x:((0) + 1) |}] @@ -311,18 +313,28 @@ let _ = let f 1 = 2 in (let 1 = 2 in 2) |}] -(* TODO *) let%expect_test "" = inline_test {| let _ = let $f (x, y) = x + y in f (1, 2) +|}; + [%expect {| + let _ = + let f (x, y) = x + y in + (1 + 2) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x, y) = x + y + y in + f (1, 2 + 3) |}; [%expect {| let _ = - let f (x, y) = x + y in - (let (x, y) = (1, 2) in x + y) |}] + let f (x, y) = x + y + y in + (let y = 2 + 3 in (1 + y) + y) |}] (* TODO *) let%expect_test "" = From a149f9a5470814fd772e9010ae46f6d2266aeadc Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Fri, 23 Sep 2022 11:19:56 -0400 Subject: [PATCH 29/39] add more tests --- ocaml-lsp-server/src/import.ml | 1 + .../test/e2e-new/action_inline.ml | 93 +++++++++++++++++++ 2 files changed, 94 insertions(+) diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index 18070b20a..441437e04 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/ocaml-lsp-server/src/import.ml @@ -110,6 +110,7 @@ module Ast_iterator = Ocaml_parsing.Ast_iterator module Asttypes = Ocaml_parsing.Asttypes module Cmt_format = Ocaml_typing.Cmt_format module Ident = Ocaml_typing.Ident +module Env = Ocaml_typing.Env module Loc = struct include Ocaml_parsing.Location diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index 43c1b8b9e..fd0a954cf 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -84,6 +84,83 @@ let _ = let x = 0 in (0) + 1 |}] +let%expect_test "shadow-1" = + inline_test + {| +let _ = + let y = 1 in + let $x = y in + let y = 0 in + x + 1 +|}; + [%expect {| |}] + +let%expect_test "shadow-2" = + inline_test + {| +let _ = + let y = 1 in + let $x y = y in + let y = 0 in + x y + 1 +|}; + [%expect {| + let _ = + let y = 1 in + let x y = y in + let y = 0 in + (y) + 1 |}] + +let%expect_test "shadow-3" = + inline_test + {| +let _ = + let y = 1 in + let $x z = y + z in + let y = 0 in + x y + 1 +|}; + [%expect {| |}] + +let%expect_test "shadow-4" = + inline_test + {| +module M = struct + let y = 1 +end +let _ = + let $x = M.y in + let module M = struct + let y = 2 + end in + x +|}; + [%expect {| |}] + +let%expect_test "shadow-5" = + inline_test + {| +module M = struct + let y = 1 +end +let _ = + let $x = M.y in + let module N = struct + let y = 2 + end in + x +|}; + [%expect {| + module M = struct + let y = 1 + end + let _ = + let x = M.y in + let module N = struct + let y = 2 + end in + (M.y) |}] + let%expect_test "" = inline_test {| let _ = @@ -290,6 +367,7 @@ let _ = let f = function Some x -> x | None -> 0 in ((function | Some x -> x | None -> 0) (Some 1)) |}] +(* TODO *) let%expect_test "" = inline_test {| let _ = @@ -336,6 +414,21 @@ let _ = let f (x, y) = x + y + y in (let y = 2 + 3 in (1 + y) + y) |}] +let%expect_test "" = + inline_test + {| +let _ = + let $f (x, y) = x + y + y in + let z = (1, 2) in + f z +|}; + [%expect + {| + let _ = + let f (x, y) = x + y + y in + let z = (1, 2) in + (let (x, y) = z in (x + y) + y) |}] + (* TODO *) let%expect_test "" = inline_test From 96478a9117a386159ea05ffce97f9d3854b545ca Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 29 Sep 2022 18:19:13 -0400 Subject: [PATCH 30/39] remove test module --- ocaml-lsp-server/src/code_actions/action_inline.ml | 8 -------- 1 file changed, 8 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index ce1414d2a..3f9eb4cd3 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -302,14 +302,6 @@ let rec beta_reduce (uses : Uses.t) (paths : Paths.t) ) | _ -> app -module Test = struct - type t = { x : int } - - let z = - let f (y : int) (z : int) a = y + z + a in - f 2 0 -end - let inlined_text pipeline task = let open Option.O in let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in From b5583a3b53f94d2d7c06f82ea3eb6e0ca02f0402 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 29 Sep 2022 18:30:15 -0400 Subject: [PATCH 31/39] update changes --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index e8250c826..962517076 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ ## Features +- Code action for inlining let bindings within a module or expression. (#847) + - Tag "unused code" and "deprecated" warnings, allowing clients to better display them. (#848) From 4e683ad74721b0ef521406c9693815a68663c46d Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Thu, 29 Sep 2022 18:31:44 -0400 Subject: [PATCH 32/39] formatting --- ocaml-lsp-server/test/e2e-new/action_inline.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index fd0a954cf..7f52c26be 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -104,7 +104,8 @@ let _ = let y = 0 in x y + 1 |}; - [%expect {| + [%expect + {| let _ = let y = 1 in let x y = y in @@ -150,7 +151,8 @@ let _ = end in x |}; - [%expect {| + [%expect + {| module M = struct let y = 1 end From 8dd4c09b6d36ac7d1ba92c2836a75657cb425c25 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Fri, 30 Sep 2022 10:52:21 -0400 Subject: [PATCH 33/39] add mli --- ocaml-lsp-server/src/code_actions/action_inline.mli | 1 + 1 file changed, 1 insertion(+) create mode 100644 ocaml-lsp-server/src/code_actions/action_inline.mli diff --git a/ocaml-lsp-server/src/code_actions/action_inline.mli b/ocaml-lsp-server/src/code_actions/action_inline.mli new file mode 100644 index 000000000..0caac27b3 --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_inline.mli @@ -0,0 +1 @@ +val t : Code_action.t From 61c087bcccbd2bc97c524d68da0a3b58de03a26d Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sat, 8 Oct 2022 10:54:19 -0400 Subject: [PATCH 34/39] use raise_notrace --- ocaml-lsp-server/src/code_actions/action_inline.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 3f9eb4cd3..6597f626f 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -28,8 +28,8 @@ let check_shadowing (inlined_expr : Typedtree.expression) new_env = match find_path_by_name ident new_env with | Some path' -> if not (Path.same path path') then - raise (Env_mismatch (ident, `Shadowed)) - | None -> raise (Env_mismatch (ident, `Unbound))) + raise_notrace (Env_mismatch (ident, `Shadowed)) + | None -> raise_notrace (Env_mismatch (ident, `Unbound))) | _ -> I.default_iterator.expr iter expr in let iter = { I.default_iterator with expr = expr_iter } in @@ -69,7 +69,8 @@ let find_inline_task typedtree pos = } ] , _ ) - when contains loc pos -> raise (Found { inlined_var; inlined_expr }) + when contains loc pos -> + raise_notrace (Found { inlined_var; inlined_expr }) | _ -> I.default_iterator.expr iter expr in let structure_item_iter (iter : I.iterator) (item : Typedtree.structure_item) @@ -83,7 +84,8 @@ let find_inline_task typedtree pos = ; _ } ] ) - when contains loc pos -> raise (Found { inlined_var; inlined_expr }) + when contains loc pos -> + raise_notrace (Found { inlined_var; inlined_expr }) | _ -> I.default_iterator.structure_item iter item in let iterator = @@ -101,7 +103,7 @@ let find_parsetree_loc pipeline loc = let exception Found of Parsetree.expression in try let expr_iter (iter : Ast_iterator.iterator) (expr : Parsetree.expression) = - if Loc.compare expr.pexp_loc loc = 0 then raise (Found expr) + if Loc.compare expr.pexp_loc loc = 0 then raise_notrace (Found expr) else Ast_iterator.default_iterator.expr iter expr in let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in From e3f469649a72c3eec4ffe1787950032920bdbbe0 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sat, 8 Oct 2022 10:54:24 -0400 Subject: [PATCH 35/39] refactor to use Option.O in whole function --- .../src/code_actions/action_inline.ml | 101 +++++++++--------- 1 file changed, 49 insertions(+), 52 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 6597f626f..70a0ab3b3 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -405,57 +405,54 @@ let inline_edits pipeline task = (edits, !error) let code_action doc (params : CodeActionParams.t) = - let open Fiber.O in - let* m_edits = - Document.with_pipeline_exn doc (fun pipeline -> - let open Option.O in - let* typedtree = - match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with - | `Interface _ -> None - | `Implementation x -> Some x - in - let* task = find_inline_task typedtree params.range.start in - inline_edits pipeline task) - in - Option.bind m_edits ~f:(fun (edits, m_error) -> - match (edits, m_error) with - | [], None -> None - | [], Some error -> - let action = - CodeAction.create - ~title:action_title - ~kind:CodeActionKind.RefactorInline - ~isPreferred:false - ~disabled: - (CodeAction.create_disabled ~reason:(string_of_error error)) - () - in - Some action - | _ :: _, (Some _ | None) -> - let edit = - let version = Document.version doc in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create - ~uri:params.textDocument.uri - ~version - () - in - let edit = - TextDocumentEdit.create - ~textDocument - ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) - in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () - in - let action = - CodeAction.create - ~title:action_title - ~kind:CodeActionKind.RefactorInline - ~edit - ~isPreferred:false - () - in - Some action) - |> Fiber.return + let open Option.O in + Document.with_pipeline_exn doc (fun pipeline -> + let* typedtree = + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> None + | `Implementation x -> Some x + in + let* task = find_inline_task typedtree params.range.start in + inline_edits pipeline task) + |> Fiber.map ~f:(fun m_edits -> + let* edits, m_error = m_edits in + match (edits, m_error) with + | [], None -> None + | [], Some error -> + let action = + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~isPreferred:false + ~disabled: + (CodeAction.create_disabled ~reason:(string_of_error error)) + () + in + Some action + | _ :: _, (Some _ | None) -> + let edit = + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri + ~version + () + in + let edit = + TextDocumentEdit.create + ~textDocument + ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () + in + let action = + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~edit + ~isPreferred:false + () + in + Some action) let t = { Code_action.kind = RefactorInline; run = code_action } From be283375f044279f839526bacf65e348c909280b Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Sat, 8 Oct 2022 11:02:53 -0400 Subject: [PATCH 36/39] explain error value --- ocaml-lsp-server/src/code_actions/action_inline.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index 70a0ab3b3..aa71fe242 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -310,6 +310,10 @@ let inlined_text pipeline task = let expr = strip_attribute "merlin.loc" expr in Format.asprintf "(%a)" Pprintast.expression expr +(** [inline_edits pipeline task] returns a list of inlining edits and an + optional error value. An error will be generated if any of the potential + inlinings is not allowed due to shadowing. The successful edits will still + be returned *) let inline_edits pipeline task = let module I = Ocaml_typing.Tast_iterator in let open Option.O in From 7f82df89ed3672dc39c11661abf018ecb3a11f95 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 10 Oct 2022 12:55:48 -0400 Subject: [PATCH 37/39] extract reusable functions --- .../test/e2e-new/action_inline.ml | 21 ++------------ ocaml-lsp-server/test/e2e-new/test.ml | 29 ++++++++++++++++++- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index 7f52c26be..6679d10bd 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -1,20 +1,10 @@ open Test.Import open Code_actions -let find_mapi ~f l = - let rec k i = function - | [] -> None - | x :: xs -> ( - match f i x with - | Some x' -> Some x' - | None -> k (i + 1) xs) - in - k 0 l - let parse_cursor src = let cursor = String.split_lines src - |> find_mapi ~f:(fun lnum line -> + |> List.find_mapi ~f:(fun lnum line -> match String.index line '$' with | Some cnum -> Some (Position.create ~character:cnum ~line:lnum) | None -> None) @@ -25,16 +15,9 @@ let parse_cursor src = | c -> Some c) , Range.create ~start:cursor ~end_:cursor ) -let rec take n l = - if n = 0 then [] - else - match l with - | [] -> failwith "list shorter than n" - | x :: xs -> x :: take (n - 1) xs - let offset_of_position src (pos : Position.t) = let line_offset = - String.split_lines src |> take pos.line + String.split_lines src |> List.take pos.line |> List.fold_left ~init:0 ~f:(fun s l -> s + String.length l) in line_offset + pos.line (* account for line endings *) + pos.character diff --git a/ocaml-lsp-server/test/e2e-new/test.ml b/ocaml-lsp-server/test/e2e-new/test.ml index fba7ed7e9..45be35b55 100644 --- a/ocaml-lsp-server/test/e2e-new/test.ml +++ b/ocaml-lsp-server/test/e2e-new/test.ml @@ -1,5 +1,32 @@ module Import = struct - include Stdune + include struct + include Stdune + + module List = struct + include List + + let find_mapi ~f l = + let rec k i = function + | [] -> None + | x :: xs -> ( + match f i x with + | Some x' -> Some x' + | None -> (k [@tailcall]) (i + 1) xs) + in + k 0 l + + let take n l = + let rec take acc n l = + if n = 0 then acc + else + match l with + | [] -> failwith "list shorter than n" + | x :: xs -> (take [@tailcall]) (x :: acc) (n - 1) xs + in + List.rev (take [] n l) + end + end + include Fiber.O module Client = Lsp_fiber.Client include Lsp.Types From dc9abcbbc6a05b2406c79d856aa830b091479cbf Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 10 Oct 2022 12:57:57 -0400 Subject: [PATCH 38/39] explain todos --- ocaml-lsp-server/test/e2e-new/action_inline.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml index 6679d10bd..daff1816c 100644 --- a/ocaml-lsp-server/test/e2e-new/action_inline.ml +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -315,7 +315,7 @@ let _ = let f (x : int) = x + 1 in (0 + 1) |}] -(* TODO *) +(* TODO: allow beta reduction with locally abstract types *) let%expect_test "" = inline_test {| let _ = @@ -352,7 +352,7 @@ let _ = let f = function Some x -> x | None -> 0 in ((function | Some x -> x | None -> 0) (Some 1)) |}] -(* TODO *) +(* TODO: allow beta reduction with `as` *) let%expect_test "" = inline_test {| let _ = @@ -430,7 +430,7 @@ let _ = let f { x; y } = x + y in (let { x; y } = { x = 1; y = 1 } in x + y) |}] -(* TODO *) +(* TODO: beta reduce record literals as with tuples *) let%expect_test "" = inline_test {| From 51c47084e253cd200691aa89acd5a91d05d14e98 Mon Sep 17 00:00:00 2001 From: Jack Feser Date: Mon, 10 Oct 2022 13:05:12 -0400 Subject: [PATCH 39/39] cleanup --- .../src/code_actions/action_inline.ml | 51 ++++++++----------- ocaml-lsp-server/src/import.ml | 29 ++++++++++- 2 files changed, 49 insertions(+), 31 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml index aa71fe242..68daf8b70 100644 --- a/ocaml-lsp-server/src/code_actions/action_inline.ml +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -1,7 +1,7 @@ open Import module H = Ocaml_parsing.Ast_helper -let action_title = "Inline" +let action_title = "Inline into uses" type inline_task = { inlined_var : Ident.t @@ -99,6 +99,8 @@ let find_inline_task typedtree pos = None with Found task -> Some task +(** [find_parsetree_loc pl loc] finds an expression node in the parsetree with + location [loc] *) let find_parsetree_loc pipeline loc = let exception Found of Parsetree.expression in try @@ -131,7 +133,13 @@ let strip_attribute attr_name expr = mapper.expr mapper expr (** Overapproximation of the number of uses of a [Path.t] in an expression. *) -module Uses = struct +module Uses : sig + type t + + val find : t -> Path.t -> int option + + val of_typedtree : Typedtree.expression -> t +end = struct type t = int Path.Map.t let find m k = Path.Map.find_opt k m @@ -158,48 +166,33 @@ end (** Mapping from [Location.t] to [Path.t]. Computed from the typedtree. Useful for determining whether two parsetree identifiers refer to the same path. *) -module Paths = struct - module Location_map = Map.Make (struct - include Loc - - let compare x x' = Ordering.of_int (compare x x') +module Paths : sig + type t - let position_to_dyn (pos : Lexing.position) = - Dyn.Record - [ ("pos_fname", Dyn.String pos.pos_fname) - ; ("pos_lnum", Dyn.Int pos.pos_lnum) - ; ("pos_bol", Dyn.Int pos.pos_bol) - ; ("pos_cnum", Dyn.Int pos.pos_cnum) - ] + val find : t -> Loc.t -> Path.t option - let to_dyn loc = - Dyn.Record - [ ("loc_start", position_to_dyn loc.loc_start) - ; ("loc_end", position_to_dyn loc.loc_end) - ; ("loc_ghost", Dyn.Bool loc.loc_ghost) - ] - end) + val of_typedtree : Typedtree.expression -> t - type t = Path.t Location_map.t + val same_path : t -> Loc.t -> Loc.t -> bool +end = struct + type t = Path.t Loc.Map.t - let find = Location_map.find + let find = Loc.Map.find let of_typedtree (expr : Typedtree.expression) = let module I = Ocaml_typing.Tast_iterator in - let paths = ref Location_map.empty in + let paths = ref Loc.Map.empty in let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = match expr.exp_desc with - | Texp_ident (path, { loc; _ }, _) -> - paths := Location_map.set !paths loc path + | Texp_ident (path, { loc; _ }, _) -> paths := Loc.Map.set !paths loc path | _ -> I.default_iterator.expr iter expr in let pat_iter (type k) (iter : I.iterator) (pat : k Typedtree.general_pattern) = match pat.pat_desc with - | Tpat_var (id, { loc; _ }) -> - paths := Location_map.set !paths loc (Pident id) + | Tpat_var (id, { loc; _ }) -> paths := Loc.Map.set !paths loc (Pident id) | Tpat_alias (pat, id, { loc; _ }) -> - paths := Location_map.set !paths loc (Pident id); + paths := Loc.Map.set !paths loc (Pident id); I.default_iterator.pat iter pat | _ -> I.default_iterator.pat iter pat in diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index 441437e04..80eb584ba 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/ocaml-lsp-server/src/import.ml @@ -113,8 +113,33 @@ module Ident = Ocaml_typing.Ident module Env = Ocaml_typing.Env module Loc = struct - include Ocaml_parsing.Location - include Ocaml_parsing.Location_aux + module T = struct + include Ocaml_parsing.Location + include Ocaml_parsing.Location_aux + end + + include T + + module Map = Map.Make (struct + include T + + let compare x x' = Ordering.of_int (compare x x') + + let position_to_dyn (pos : Lexing.position) = + Dyn.Record + [ ("pos_fname", Dyn.String pos.pos_fname) + ; ("pos_lnum", Dyn.Int pos.pos_lnum) + ; ("pos_bol", Dyn.Int pos.pos_bol) + ; ("pos_cnum", Dyn.Int pos.pos_cnum) + ] + + let to_dyn loc = + Dyn.Record + [ ("loc_start", position_to_dyn loc.loc_start) + ; ("loc_end", position_to_dyn loc.loc_end) + ; ("loc_ghost", Dyn.Bool loc.loc_ghost) + ] + end) end module Longident = Ocaml_parsing.Longident