From e50147f55759a94e415b303e9f1466cc3990d68f Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Fri, 10 Mar 2023 12:37:57 +0100 Subject: [PATCH 01/10] WIP: Fix type-annotate action for functions --- .../src/code_actions/action_type_annotate.ml | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 62cb57e6f..8697c9394 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -4,25 +4,29 @@ open Fiber.O let action_kind = "type-annotate" let check_typeable_context pipeline pos_start = + let open Typedtree in let pos_start = Mpipeline.get_lexing_pos pipeline pos_start in let typer = Mpipeline.typer_result pipeline in let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in let is_exp_constrained = function - | Typedtree.Texp_constraint _, _, _ -> true - | Typedtree.Texp_coerce (Some _, _), _, _ -> true + | Texp_constraint _, _, _ -> true + | Texp_coerce (Some _, _), _, _ -> true | _ -> false in let is_pat_constrained = function - | Typedtree.Tpat_constraint _, _, _ -> true + | Tpat_constraint _, _, _ -> true | _ -> false in let is_valid p extras = if List.exists ~f:p extras then `Invalid else `Valid in match Mbrowse.enclosing pos_start [ browse ] with + | (_, Pattern { pat_desc = Tpat_var _; _}) + :: (_, Value_binding { vb_expr = { exp_desc = Texp_function _; _} ; _ }) + :: _ -> `Invalid (* TODO: traverse function arguments *) | (_, Expression e) :: _ -> is_valid is_exp_constrained e.exp_extra - | (_, Pattern { pat_desc = Typedtree.Tpat_any; _ }) - :: (_, Pattern { pat_desc = Typedtree.Tpat_alias _; pat_extra; _ }) + | (_, Pattern { pat_desc = Tpat_any; _ }) + :: (_, Pattern { pat_desc = Tpat_alias _; pat_extra; _ }) :: _ -> is_valid is_pat_constrained pat_extra | (_, Pattern p) :: _ -> is_valid is_pat_constrained p.pat_extra | _ :: _ | [] -> `Invalid From da7ef75c5ba96e08f932f83d18ab4e85c37a7cbc Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Mon, 13 Mar 2023 14:35:43 +0100 Subject: [PATCH 02/10] Super hacky and barely working --- .../src/code_actions/action_type_annotate.ml | 97 +++++++++++++++++-- 1 file changed, 89 insertions(+), 8 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 8697c9394..fa889f56d 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -20,10 +20,50 @@ let check_typeable_context pipeline pos_start = let is_valid p extras = if List.exists ~f:p extras then `Invalid else `Valid in + let rec trav_cases (i : int) = function + | { c_rhs = + { exp_desc = + Texp_function + { cases = + [ { c_lhs = { pat_desc = Tpat_var _; _ } + ; c_rhs = { exp_desc = Texp_function {cases; _}; _ } + ; _ + } + ] + ; _ + } + ; _ + } + ; _ + } + :: _ -> trav_cases (i + 1) cases + | { c_rhs = + { exp_desc = + Texp_function + { cases = + [ { c_lhs = { pat_desc = _; pat_loc; _ } + ; c_rhs = { exp_extra; _ } + ; _ + } + ] + ; _ + } + ; exp_loc + ; _ + } + ; _ + } + :: _ -> + if List.exists ~f:is_exp_constrained exp_extra then `Invalid + else `Valid_fun (i, pat_loc, exp_loc) + | _ :: _ | [] -> `Invalid + in match Mbrowse.enclosing pos_start [ browse ] with - | (_, Pattern { pat_desc = Tpat_var _; _}) - :: (_, Value_binding { vb_expr = { exp_desc = Texp_function _; _} ; _ }) - :: _ -> `Invalid (* TODO: traverse function arguments *) + | (_, Pattern { pat_desc = Tpat_var _; _ }) + :: ( _ + , Value_binding + { vb_expr = { exp_desc = Texp_function { cases; _ }; _ }; _ } ) + :: _ -> trav_cases 2 cases | (_, Expression e) :: _ -> is_valid is_exp_constrained e.exp_extra | (_, Pattern { pat_desc = Tpat_any; _ }) :: (_, Pattern { pat_desc = Tpat_alias _; pat_extra; _ }) @@ -63,6 +103,35 @@ let code_action_of_type_enclosing uri doc (loc, typ) = ~isPreferred:false () +let code_action_of_type_enclosing' uri doc (loc, arg_len, typ) = + let open Option.O in + let+ original_text = get_source_text doc loc in + let arrow = " -> " in + let typ' = + Str.split (Str.regexp arrow) typ + |> List.to_seq |> Seq.drop arg_len |> List.of_seq + |> String.concat ~sep:arrow + in + let newText = Printf.sprintf "%s : %s" original_text typ' in + let edit : WorkspaceEdit.t = + let textedit : TextEdit.t = { range = Range.of_loc loc; newText } in + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create ~uri ~version () + in + let edit = + TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit textedit ] + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () + in + let title = String.capitalize_ascii action_kind in + CodeAction.create + ~title + ~kind:(CodeActionKind.Other action_kind) + ~edit + ~isPreferred:false + () + let code_action doc (params : CodeActionParams.t) = match Document.kind doc with | `Other -> Fiber.return None @@ -72,7 +141,17 @@ let code_action doc (params : CodeActionParams.t) = Document.Merlin.with_pipeline_exn merlin (fun pipeline -> let context = check_typeable_context pipeline pos_start in match context with - | `Invalid -> None + | `Invalid -> `None + | `Valid_fun (i, pat_loc, _ ) -> + let command = + Query_protocol.Type_enclosing (None, pos_start (*`Logical (exp_loc.loc_end.pos_lnum, exp_loc.loc_end.pos_cnum)*), None) + in + let config = Mpipeline.final_config pipeline in + let config = + { config with query = { config.query with verbosity = Lvl 0 } } + in + let pipeline = Mpipeline.make config (Document.source doc) in + `Some_fun (Query_commands.dispatch pipeline command, pat_loc, i) | `Valid -> let command = Query_protocol.Type_enclosing (None, pos_start, None) @@ -82,13 +161,15 @@ let code_action doc (params : CodeActionParams.t) = { config with query = { config.query with verbosity = Lvl 0 } } in let pipeline = Mpipeline.make config (Document.source doc) in - Some (Query_commands.dispatch pipeline command)) + `Some (Query_commands.dispatch pipeline command)) in match res with - | None | Some [] | Some ((_, `Index _, _) :: _) -> None - | Some ((location, `String value, _) :: _) -> + | `None | `Some [] | `Some ((_, `Index _, _) :: _) -> None + | `Some ((location, `String value, _) :: _) -> code_action_of_type_enclosing params.textDocument.uri doc (location, value) - ) + | `Some_fun ((_, `String value, _) :: _, loc, i) -> + code_action_of_type_enclosing' params.textDocument.uri doc (loc, i, value) + | _ -> None) let t = { Code_action.kind = CodeActionKind.Other action_kind; run = code_action } From 1b352314c5ac8680eefec51874297898bdc6c46d Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Mon, 13 Mar 2023 16:51:25 +0100 Subject: [PATCH 03/10] Only works for two args (lol) --- .../src/code_actions/action_type_annotate.ml | 6 ++-- ocaml-lsp-server/test/e2e-new/code_actions.ml | 35 +++++++++++++++++++ 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index fa889f56d..230a2ac08 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -26,7 +26,7 @@ let check_typeable_context pipeline pos_start = Texp_function { cases = [ { c_lhs = { pat_desc = Tpat_var _; _ } - ; c_rhs = { exp_desc = Texp_function {cases; _}; _ } + ; c_rhs = { exp_desc = Texp_function { cases; _ }; _ } ; _ } ] @@ -142,9 +142,9 @@ let code_action doc (params : CodeActionParams.t) = let context = check_typeable_context pipeline pos_start in match context with | `Invalid -> `None - | `Valid_fun (i, pat_loc, _ ) -> + | `Valid_fun (i, pat_loc, _) -> let command = - Query_protocol.Type_enclosing (None, pos_start (*`Logical (exp_loc.loc_end.pos_lnum, exp_loc.loc_end.pos_cnum)*), None) + Query_protocol.Type_enclosing (None, pos_start, None) in let config = Mpipeline.final_config pipeline in let config = diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 6f812ea6e..f7e88ee1d 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -209,6 +209,41 @@ let iiii = 3 + 4 } |}] +let%expect_test "can type-annotate a function" = + let source = {ocaml| +let my_fun x y = x + 1 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:6 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_annotate_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "y : int", + "range": { + "end": { "character": 14, "line": 1 }, + "start": { "character": 13, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "type-annotate", + "title": "Type-annotate" + } |}] + let%expect_test "can type-annotate an argument in a function call" = let source = {ocaml| From d37ffeefe423c01ae923c284ad1ca4939a0b2817 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Wed, 15 Mar 2023 16:15:55 +0100 Subject: [PATCH 04/10] Mega hacky, but seems to work? --- .../src/code_actions/action_type_annotate.ml | 51 +++++------- ocaml-lsp-server/test/e2e-new/code_actions.ml | 78 ++++++++++++++++++- 2 files changed, 95 insertions(+), 34 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 230a2ac08..5b1b13e9b 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -17,53 +17,44 @@ let check_typeable_context pipeline pos_start = | Tpat_constraint _, _, _ -> true | _ -> false in + let pat_constraint_loc = function + | Typedtree.Tpat_constraint _, loc, _ -> Some loc + | _ -> None + in let is_valid p extras = if List.exists ~f:p extras then `Invalid else `Valid in let rec trav_cases (i : int) = function - | { c_rhs = - { exp_desc = - Texp_function - { cases = - [ { c_lhs = { pat_desc = Tpat_var _; _ } - ; c_rhs = { exp_desc = Texp_function { cases; _ }; _ } - ; _ - } - ] - ; _ - } - ; _ - } + | { c_lhs = { pat_desc = Tpat_var _; _ } + ; c_rhs = { exp_desc = Texp_function { cases; _ }; _ } ; _ } :: _ -> trav_cases (i + 1) cases - | { c_rhs = - { exp_desc = - Texp_function - { cases = - [ { c_lhs = { pat_desc = _; pat_loc; _ } - ; c_rhs = { exp_extra; _ } - ; _ - } - ] - ; _ - } - ; exp_loc - ; _ - } + | { c_lhs = { pat_desc = Tpat_var _; pat_loc; _ } + ; c_rhs = { exp_extra; exp_loc; _ } ; _ } :: _ -> if List.exists ~f:is_exp_constrained exp_extra then `Invalid else `Valid_fun (i, pat_loc, exp_loc) - | _ :: _ | [] -> `Invalid + | { c_lhs = { pat_desc = Tpat_alias _; pat_loc; pat_extra; _ } + ; c_rhs = { exp_extra; exp_loc; _ } + ; _ + } + :: _ -> ( + if List.exists ~f:is_exp_constrained exp_extra then `Invalid + else + match pat_extra |> List.rev |> List.find_map ~f:pat_constraint_loc with + | Some loc -> `Valid_fun (i, Loc.union pat_loc loc, exp_loc) + | None -> `Valid_fun (i, pat_loc, exp_loc)) + | _ -> `Invalid in match Mbrowse.enclosing pos_start [ browse ] with | (_, Pattern { pat_desc = Tpat_var _; _ }) :: ( _ , Value_binding { vb_expr = { exp_desc = Texp_function { cases; _ }; _ }; _ } ) - :: _ -> trav_cases 2 cases + :: _ -> trav_cases 1 cases | (_, Expression e) :: _ -> is_valid is_exp_constrained e.exp_extra | (_, Pattern { pat_desc = Tpat_any; _ }) :: (_, Pattern { pat_desc = Tpat_alias _; pat_extra; _ }) @@ -108,7 +99,7 @@ let code_action_of_type_enclosing' uri doc (loc, arg_len, typ) = let+ original_text = get_source_text doc loc in let arrow = " -> " in let typ' = - Str.split (Str.regexp arrow) typ + Re.split (Re.compile (Re.str arrow)) typ |> List.to_seq |> Seq.drop arg_len |> List.of_seq |> String.concat ~sep:arrow in diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index f7e88ee1d..1add75a44 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -209,9 +209,9 @@ let iiii = 3 + 4 } |}] -let%expect_test "can type-annotate a function" = +let%expect_test "can type-annotate a single arg function" = let source = {ocaml| -let my_fun x y = x + 1 +let my_fun x = x + 1 |ocaml} in let range = let start = Position.create ~line:1 ~character:5 in @@ -228,9 +228,79 @@ let my_fun x y = x + 1 { "edits": [ { - "newText": "y : int", + "newText": "x : int", "range": { - "end": { "character": 14, "line": 1 }, + "end": { "character": 12, "line": 1 }, + "start": { "character": 11, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "type-annotate", + "title": "Type-annotate" + } |}] + +let%expect_test "can type-annotate a multi arg function" = + let source = {ocaml| +let my_fun a b c d e (f : int) = f + 1 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:6 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_annotate_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "(f : int) : int", + "range": { + "end": { "character": 30, "line": 1 }, + "start": { "character": 21, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "type-annotate", + "title": "Type-annotate" + } |}] + +let%expect_test "can type-annotate a function that returns function" = + let source = {ocaml| +let my_fun x (y: int) = (fun a -> x + 1) +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:6 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_annotate_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "(y: int) : 'a -> int", + "range": { + "end": { "character": 21, "line": 1 }, "start": { "character": 13, "line": 1 } } } From af149c2b7bbbab3aeeb16454d1630e1e4fbd2415 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Wed, 15 Mar 2023 16:41:22 +0100 Subject: [PATCH 05/10] Add type annotation removal --- .../action_remove_type_annotation.ml | 34 +++++- ocaml-lsp-server/test/e2e-new/code_actions.ml | 107 ++++++++++++++++++ 2 files changed, 138 insertions(+), 3 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_remove_type_annotation.ml b/ocaml-lsp-server/src/code_actions/action_remove_type_annotation.ml index 6221be898..dc40fe027 100644 --- a/ocaml-lsp-server/src/code_actions/action_remove_type_annotation.ml +++ b/ocaml-lsp-server/src/code_actions/action_remove_type_annotation.ml @@ -3,16 +3,17 @@ open Import let action_kind = "remove type annotation" let check_typeable_context pipeline pos_start = + let open Typedtree in let pos_start = Mpipeline.get_lexing_pos pipeline pos_start in let typer = Mpipeline.typer_result pipeline in let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in let is_exp_constrained = function - | Typedtree.Texp_constraint _, loc, _ -> Some loc - | Typedtree.Texp_coerce (Some { ctyp_loc; _ }, _), _, _ -> Some ctyp_loc + | Texp_constraint { ctyp_loc; _ }, _, _ -> Some ctyp_loc + | Texp_coerce (Some { ctyp_loc; _ }, _), _, _ -> Some ctyp_loc | _ -> None in let is_pat_constrained = function - | Typedtree.Tpat_constraint _, loc, _ -> Some loc + | Tpat_constraint _, loc, _ -> Some loc | _ -> None in let is_valid loc p extras = @@ -22,7 +23,34 @@ let check_typeable_context pipeline pos_start = | Some x -> `Valid (loc, x) | None -> `Invalid in + let rec trav_cases = function + | { c_lhs = { pat_desc = Tpat_var _; _ } + ; c_rhs = { exp_desc = Texp_function { cases; _ }; _ } + ; _ + } + :: _ -> trav_cases cases + | { c_lhs = { pat_desc = Tpat_var _; pat_loc; _ } + ; c_rhs = { exp_extra; _ } + ; _ + } + :: _ -> is_valid pat_loc is_exp_constrained exp_extra + | { c_lhs = { pat_desc = Tpat_alias _; pat_loc; pat_extra; _ } + ; c_rhs = { exp_extra; _ } + ; _ + } + :: _ -> ( + match is_valid pat_loc is_pat_constrained pat_extra with + | `Valid (_, loc) -> + is_valid (Loc.union pat_loc loc) is_exp_constrained exp_extra + | `Invalid -> is_valid pat_loc is_exp_constrained exp_extra) + | _ -> `Invalid + in match Mbrowse.enclosing pos_start [ browse ] with + | (_, Pattern { pat_desc = Tpat_var _; _ }) + :: ( _ + , Value_binding + { vb_expr = { exp_desc = Texp_function { cases; _ }; _ }; _ } ) + :: _ -> trav_cases cases | (_, Expression e) :: _ -> is_valid e.exp_loc is_exp_constrained e.exp_extra | (_, Pattern { pat_desc = Typedtree.Tpat_any; pat_loc; _ }) :: (_, Pattern { pat_desc = Typedtree.Tpat_alias _; pat_extra; _ }) diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 1add75a44..78aab27c8 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -517,6 +517,113 @@ let (iiii : int) = 3 + 4 "title": "Remove type annotation" } |}] +let%expect_test "can remove type annotation from a function with single arg" = + let source = {ocaml| +let f x : int = x + 1 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:4 in + let end_ = Position.create ~line:1 ~character:5 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_remove_annotation_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "x", + "range": { + "end": { "character": 13, "line": 1 }, + "start": { "character": 6, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "remove type annotation", + "title": "Remove type annotation" + } |}] + +let%expect_test "can remove type annotation from a function with multiple args" + = + let source = {ocaml| +let f v w x y z : int = x + 1 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:4 in + let end_ = Position.create ~line:1 ~character:5 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_remove_annotation_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "z", + "range": { + "end": { "character": 21, "line": 1 }, + "start": { "character": 14, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "remove type annotation", + "title": "Remove type annotation" + } |}] + +let%expect_test "can remove type annotation from a function with annotated arg" + = + let source = {ocaml| +let f x y (z : int) : int = x + 1 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:4 in + let end_ = Position.create ~line:1 ~character:5 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_remove_annotation_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "(z : int)", + "range": { + "end": { "character": 25, "line": 1 }, + "start": { "character": 10, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "remove type annotation", + "title": "Remove type annotation" + } |}] + let%expect_test "can remove type annotation from an argument in a function call" = let source = From 6d3b0151ecf808d6cc90421e7aed9f1303bfbcd2 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 16 Mar 2023 13:16:44 +0100 Subject: [PATCH 06/10] Use type directly from typetree --- .../src/code_actions/action_type_annotate.ml | 46 ++++++++----------- ocaml-lsp-server/src/signature_help.mli | 2 + ocaml-lsp-server/test/e2e-new/code_actions.ml | 37 +++++++++++++++ 3 files changed, 58 insertions(+), 27 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 5b1b13e9b..a9b10cc51 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -24,29 +24,30 @@ let check_typeable_context pipeline pos_start = let is_valid p extras = if List.exists ~f:p extras then `Invalid else `Valid in - let rec trav_cases (i : int) = function + let rec trav_cases = function | { c_lhs = { pat_desc = Tpat_var _; _ } ; c_rhs = { exp_desc = Texp_function { cases; _ }; _ } ; _ } - :: _ -> trav_cases (i + 1) cases + :: _ -> trav_cases cases | { c_lhs = { pat_desc = Tpat_var _; pat_loc; _ } - ; c_rhs = { exp_extra; exp_loc; _ } + ; c_rhs = { exp_extra; exp_loc; exp_type; exp_env; _ } ; _ } :: _ -> if List.exists ~f:is_exp_constrained exp_extra then `Invalid - else `Valid_fun (i, pat_loc, exp_loc) + else `Valid_fun (exp_env, exp_type, pat_loc, exp_loc) | { c_lhs = { pat_desc = Tpat_alias _; pat_loc; pat_extra; _ } - ; c_rhs = { exp_extra; exp_loc; _ } + ; c_rhs = { exp_extra; exp_loc; exp_type; exp_env; _ } ; _ } :: _ -> ( if List.exists ~f:is_exp_constrained exp_extra then `Invalid else match pat_extra |> List.rev |> List.find_map ~f:pat_constraint_loc with - | Some loc -> `Valid_fun (i, Loc.union pat_loc loc, exp_loc) - | None -> `Valid_fun (i, pat_loc, exp_loc)) + | Some loc -> + `Valid_fun (exp_env, exp_type, Loc.union pat_loc loc, exp_loc) + | None -> `Valid_fun (exp_env, exp_type, pat_loc, exp_loc)) | _ -> `Invalid in match Mbrowse.enclosing pos_start [ browse ] with @@ -54,7 +55,7 @@ let check_typeable_context pipeline pos_start = :: ( _ , Value_binding { vb_expr = { exp_desc = Texp_function { cases; _ }; _ }; _ } ) - :: _ -> trav_cases 1 cases + :: _ -> trav_cases cases | (_, Expression e) :: _ -> is_valid is_exp_constrained e.exp_extra | (_, Pattern { pat_desc = Tpat_any; _ }) :: (_, Pattern { pat_desc = Tpat_alias _; pat_extra; _ }) @@ -94,16 +95,16 @@ let code_action_of_type_enclosing uri doc (loc, typ) = ~isPreferred:false () -let code_action_of_type_enclosing' uri doc (loc, arg_len, typ) = +let code_action_of_type_enclosing' uri doc (loc, env, typ) = let open Option.O in let+ original_text = get_source_text doc loc in - let arrow = " -> " in - let typ' = - Re.split (Re.compile (Re.str arrow)) typ - |> List.to_seq |> Seq.drop arg_len |> List.of_seq - |> String.concat ~sep:arrow + let buffer = Buffer.create 16 in + let ppf = Format.formatter_of_buffer buffer in + let typ_str = + Format.fprintf ppf "%a%!" (Signature_help.pp_type env) typ; + Buffer.contents buffer in - let newText = Printf.sprintf "%s : %s" original_text typ' in + let newText = Printf.sprintf "%s : %s" original_text typ_str in let edit : WorkspaceEdit.t = let textedit : TextEdit.t = { range = Range.of_loc loc; newText } in let version = Document.version doc in @@ -133,16 +134,7 @@ let code_action doc (params : CodeActionParams.t) = let context = check_typeable_context pipeline pos_start in match context with | `Invalid -> `None - | `Valid_fun (i, pat_loc, _) -> - let command = - Query_protocol.Type_enclosing (None, pos_start, None) - in - let config = Mpipeline.final_config pipeline in - let config = - { config with query = { config.query with verbosity = Lvl 0 } } - in - let pipeline = Mpipeline.make config (Document.source doc) in - `Some_fun (Query_commands.dispatch pipeline command, pat_loc, i) + | `Valid_fun (env, typ, pat_loc, _) -> `Some_fun (pat_loc, env, typ) | `Valid -> let command = Query_protocol.Type_enclosing (None, pos_start, None) @@ -158,8 +150,8 @@ let code_action doc (params : CodeActionParams.t) = | `None | `Some [] | `Some ((_, `Index _, _) :: _) -> None | `Some ((location, `String value, _) :: _) -> code_action_of_type_enclosing params.textDocument.uri doc (location, value) - | `Some_fun ((_, `String value, _) :: _, loc, i) -> - code_action_of_type_enclosing' params.textDocument.uri doc (loc, i, value) + | `Some_fun (loc, env, typ) -> + code_action_of_type_enclosing' params.textDocument.uri doc (loc, env, typ) | _ -> None) let t = diff --git a/ocaml-lsp-server/src/signature_help.mli b/ocaml-lsp-server/src/signature_help.mli index 0f9377c27..c32a7200e 100644 --- a/ocaml-lsp-server/src/signature_help.mli +++ b/ocaml-lsp-server/src/signature_help.mli @@ -1,3 +1,5 @@ open Import +val pp_type : Env.t -> Format.formatter -> Types.type_expr -> unit + val run : State.t -> SignatureHelpParams.t -> SignatureHelp.t Fiber.t diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 78aab27c8..9dc58a82e 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -314,6 +314,43 @@ let my_fun x (y: int) = (fun a -> x + 1) "title": "Type-annotate" } |}] +let%expect_test "can type-annotate a higher-order function" = + let source = + {ocaml| +let my_fun x (y: int -> int -> int) = (fun a -> x + 1) +|ocaml} + in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:6 in + Range.create ~start ~end_ + in + print_code_actions source range ~filter:find_annotate_action; + [%expect + {| + Code actions: + { + "edit": { + "documentChanges": [ + { + "edits": [ + { + "newText": "(y: int -> int -> int) : 'a -> int", + "range": { + "end": { "character": 35, "line": 1 }, + "start": { "character": 13, "line": 1 } + } + } + ], + "textDocument": { "uri": "file:///foo.ml", "version": 0 } + } + ] + }, + "isPreferred": false, + "kind": "type-annotate", + "title": "Type-annotate" + } |}] + let%expect_test "can type-annotate an argument in a function call" = let source = {ocaml| From 7dcefb935c7353cf2840843a30977b47f55bce7d Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 16 Mar 2023 13:56:20 +0100 Subject: [PATCH 07/10] Remove redundant type_enclosing call --- .../src/code_actions/action_type_annotate.ml | 83 ++++++------------- 1 file changed, 26 insertions(+), 57 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index a9b10cc51..121c8b96c 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -1,5 +1,4 @@ open Import -open Fiber.O let action_kind = "type-annotate" @@ -21,8 +20,8 @@ let check_typeable_context pipeline pos_start = | Typedtree.Tpat_constraint _, loc, _ -> Some loc | _ -> None in - let is_valid p extras = - if List.exists ~f:p extras then `Invalid else `Valid + let is_valid env typ loc p extras = + if List.exists ~f:p extras then `Invalid else `Valid (env, typ, loc) in let rec trav_cases = function | { c_lhs = { pat_desc = Tpat_var _; _ } @@ -56,11 +55,13 @@ let check_typeable_context pipeline pos_start = , Value_binding { vb_expr = { exp_desc = Texp_function { cases; _ }; _ }; _ } ) :: _ -> trav_cases cases - | (_, Expression e) :: _ -> is_valid is_exp_constrained e.exp_extra - | (_, Pattern { pat_desc = Tpat_any; _ }) + | (_, Expression e) :: _ -> + is_valid e.exp_env e.exp_type e.exp_loc is_exp_constrained e.exp_extra + | (_, Pattern { pat_desc = Tpat_any; pat_loc; pat_env; pat_type; _ }) :: (_, Pattern { pat_desc = Tpat_alias _; pat_extra; _ }) - :: _ -> is_valid is_pat_constrained pat_extra - | (_, Pattern p) :: _ -> is_valid is_pat_constrained p.pat_extra + :: _ -> is_valid pat_env pat_type pat_loc is_pat_constrained pat_extra + | (_, Pattern p) :: _ -> + is_valid p.pat_env p.pat_type p.pat_loc is_pat_constrained p.pat_extra | _ :: _ | [] -> `Invalid let get_source_text doc (loc : Loc.t) = @@ -72,30 +73,7 @@ let get_source_text doc (loc : Loc.t) = let (`Offset end_) = Msource.get_offset source (Position.logical end_) in String.sub (Msource.text source) ~pos:start ~len:(end_ - start) -let code_action_of_type_enclosing uri doc (loc, typ) = - let open Option.O in - let+ original_text = get_source_text doc loc in - let newText = Printf.sprintf "(%s : %s)" original_text typ in - let edit : WorkspaceEdit.t = - let textedit : TextEdit.t = { range = Range.of_loc loc; newText } in - let version = Document.version doc in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create ~uri ~version () - in - let edit = - TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit textedit ] - in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () - in - let title = String.capitalize_ascii action_kind in - CodeAction.create - ~title - ~kind:(CodeActionKind.Other action_kind) - ~edit - ~isPreferred:false - () - -let code_action_of_type_enclosing' uri doc (loc, env, typ) = +let code_action_of_type_enclosing uri doc str_fmt (loc, env, typ) = let open Option.O in let+ original_text = get_source_text doc loc in let buffer = Buffer.create 16 in @@ -104,7 +82,7 @@ let code_action_of_type_enclosing' uri doc (loc, env, typ) = Format.fprintf ppf "%a%!" (Signature_help.pp_type env) typ; Buffer.contents buffer in - let newText = Printf.sprintf "%s : %s" original_text typ_str in + let newText = Printf.sprintf str_fmt original_text typ_str in let edit : WorkspaceEdit.t = let textedit : TextEdit.t = { range = Range.of_loc loc; newText } in let version = Document.version doc in @@ -127,32 +105,23 @@ let code_action_of_type_enclosing' uri doc (loc, env, typ) = let code_action doc (params : CodeActionParams.t) = match Document.kind doc with | `Other -> Fiber.return None - | `Merlin merlin -> ( + | `Merlin merlin -> let pos_start = Position.logical params.range.start in - let+ res = - Document.Merlin.with_pipeline_exn merlin (fun pipeline -> - let context = check_typeable_context pipeline pos_start in - match context with - | `Invalid -> `None - | `Valid_fun (env, typ, pat_loc, _) -> `Some_fun (pat_loc, env, typ) - | `Valid -> - let command = - Query_protocol.Type_enclosing (None, pos_start, None) - in - let config = Mpipeline.final_config pipeline in - let config = - { config with query = { config.query with verbosity = Lvl 0 } } - in - let pipeline = Mpipeline.make config (Document.source doc) in - `Some (Query_commands.dispatch pipeline command)) - in - match res with - | `None | `Some [] | `Some ((_, `Index _, _) :: _) -> None - | `Some ((location, `String value, _) :: _) -> - code_action_of_type_enclosing params.textDocument.uri doc (location, value) - | `Some_fun (loc, env, typ) -> - code_action_of_type_enclosing' params.textDocument.uri doc (loc, env, typ) - | _ -> None) + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> + match check_typeable_context pipeline pos_start with + | `Invalid -> None + | `Valid_fun (env, typ, pat_loc, _) -> + code_action_of_type_enclosing + params.textDocument.uri + doc + "%s : %s" + (pat_loc, env, typ) + | `Valid (env, typ, loc) -> + code_action_of_type_enclosing + params.textDocument.uri + doc + "(%s : %s)" + (loc, env, typ)) let t = { Code_action.kind = CodeActionKind.Other action_kind; run = code_action } From b0d6042869562a5fbcee6862e59610190419d691 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 16 Mar 2023 14:00:00 +0100 Subject: [PATCH 08/10] Inline pp_type --- ocaml-lsp-server/src/code_actions/action_type_annotate.ml | 8 +++++++- ocaml-lsp-server/src/signature_help.mli | 2 -- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 121c8b96c..6f8955880 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -78,8 +78,14 @@ let code_action_of_type_enclosing uri doc str_fmt (loc, env, typ) = let+ original_text = get_source_text doc loc in let buffer = Buffer.create 16 in let ppf = Format.formatter_of_buffer buffer in + let pp_type env ppf ty = + let open Merlin_analysis in + let module Printtyp = Type_utils.Printtyp in + Printtyp.wrap_printing_env env ~verbosity:(Lvl 0) (fun () -> + Printtyp.shared_type_scheme ppf ty) + in let typ_str = - Format.fprintf ppf "%a%!" (Signature_help.pp_type env) typ; + Format.fprintf ppf "%a%!" (pp_type env) typ; Buffer.contents buffer in let newText = Printf.sprintf str_fmt original_text typ_str in diff --git a/ocaml-lsp-server/src/signature_help.mli b/ocaml-lsp-server/src/signature_help.mli index c32a7200e..0f9377c27 100644 --- a/ocaml-lsp-server/src/signature_help.mli +++ b/ocaml-lsp-server/src/signature_help.mli @@ -1,5 +1,3 @@ open Import -val pp_type : Env.t -> Format.formatter -> Types.type_expr -> unit - val run : State.t -> SignatureHelpParams.t -> SignatureHelp.t Fiber.t From c9aefafa22c1322e4b7615ea61b57ec3aa0a371d Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 16 Mar 2023 14:10:19 +0100 Subject: [PATCH 09/10] Simplify further --- .../src/code_actions/action_type_annotate.ml | 46 ++++++++----------- 1 file changed, 19 insertions(+), 27 deletions(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 6f8955880..f1f5e677c 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -30,23 +30,22 @@ let check_typeable_context pipeline pos_start = } :: _ -> trav_cases cases | { c_lhs = { pat_desc = Tpat_var _; pat_loc; _ } - ; c_rhs = { exp_extra; exp_loc; exp_type; exp_env; _ } + ; c_rhs = { exp_extra; exp_type; exp_env; _ } ; _ } :: _ -> if List.exists ~f:is_exp_constrained exp_extra then `Invalid - else `Valid_fun (exp_env, exp_type, pat_loc, exp_loc) + else `Valid_fun (exp_env, exp_type, pat_loc) | { c_lhs = { pat_desc = Tpat_alias _; pat_loc; pat_extra; _ } - ; c_rhs = { exp_extra; exp_loc; exp_type; exp_env; _ } + ; c_rhs = { exp_extra; exp_type; exp_env; _ } ; _ } :: _ -> ( if List.exists ~f:is_exp_constrained exp_extra then `Invalid else match pat_extra |> List.rev |> List.find_map ~f:pat_constraint_loc with - | Some loc -> - `Valid_fun (exp_env, exp_type, Loc.union pat_loc loc, exp_loc) - | None -> `Valid_fun (exp_env, exp_type, pat_loc, exp_loc)) + | Some loc -> `Valid_fun (exp_env, exp_type, Loc.union pat_loc loc) + | None -> `Valid_fun (exp_env, exp_type, pat_loc)) | _ -> `Invalid in match Mbrowse.enclosing pos_start [ browse ] with @@ -73,18 +72,18 @@ let get_source_text doc (loc : Loc.t) = let (`Offset end_) = Msource.get_offset source (Position.logical end_) in String.sub (Msource.text source) ~pos:start ~len:(end_ - start) -let code_action_of_type_enclosing uri doc str_fmt (loc, env, typ) = +let code_action uri doc str_fmt (env, typ, loc) = let open Option.O in let+ original_text = get_source_text doc loc in - let buffer = Buffer.create 16 in - let ppf = Format.formatter_of_buffer buffer in - let pp_type env ppf ty = - let open Merlin_analysis in - let module Printtyp = Type_utils.Printtyp in - Printtyp.wrap_printing_env env ~verbosity:(Lvl 0) (fun () -> - Printtyp.shared_type_scheme ppf ty) - in let typ_str = + let buffer = Buffer.create 16 in + let ppf = Format.formatter_of_buffer buffer in + let pp_type env ppf ty = + let open Merlin_analysis in + let module Printtyp = Type_utils.Printtyp in + Printtyp.wrap_printing_env env ~verbosity:(Lvl 0) (fun () -> + Printtyp.shared_type_scheme ppf ty) + in Format.fprintf ppf "%a%!" (pp_type env) typ; Buffer.contents buffer in @@ -113,21 +112,14 @@ let code_action doc (params : CodeActionParams.t) = | `Other -> Fiber.return None | `Merlin merlin -> let pos_start = Position.logical params.range.start in + let action fmt_str data = + code_action params.textDocument.uri doc fmt_str data + in Document.Merlin.with_pipeline_exn merlin (fun pipeline -> match check_typeable_context pipeline pos_start with | `Invalid -> None - | `Valid_fun (env, typ, pat_loc, _) -> - code_action_of_type_enclosing - params.textDocument.uri - doc - "%s : %s" - (pat_loc, env, typ) - | `Valid (env, typ, loc) -> - code_action_of_type_enclosing - params.textDocument.uri - doc - "(%s : %s)" - (loc, env, typ)) + | `Valid_fun x -> action "%s : %s" x + | `Valid x -> action "(%s : %s)" x) let t = { Code_action.kind = CodeActionKind.Other action_kind; run = code_action } From ff2fd0169fdf25641ef18d993656aa03d70c8177 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 16 Mar 2023 14:30:32 +0100 Subject: [PATCH 10/10] Fix Printtyp --- ocaml-lsp-server/src/code_actions/action_type_annotate.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index f1f5e677c..13c64eae1 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -82,7 +82,7 @@ let code_action uri doc str_fmt (env, typ, loc) = let open Merlin_analysis in let module Printtyp = Type_utils.Printtyp in Printtyp.wrap_printing_env env ~verbosity:(Lvl 0) (fun () -> - Printtyp.shared_type_scheme ppf ty) + Printtyp.type_expr ppf ty) in Format.fprintf ppf "%a%!" (pp_type env) typ; Buffer.contents buffer