From 94eff5ad1ee8b2381c6d7b26556800625091cf64 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 21:30:51 +0200 Subject: [PATCH 01/44] base setup for actions + tests --- compiler/bsc/rescript_compiler_main.ml | 2 + compiler/ml/cmt_format.ml | 32 ++++++++- compiler/ml/cmt_format.mli | 2 + compiler/ml/cmt_utils.ml | 12 ++++ compiler/ml/env.ml | 4 +- compiler/ml/error_message_utils.ml | 26 +++++++ compiler/ml/parmatch.ml | 10 ++- compiler/ml/typecore.ml | 15 ++-- lib_dev/process.js | 13 ++++ tests/build_tests/actions/ACTIONS_TESTS.md | 8 +++ .../Actions_ApplyCoercion_applied.res | 5 ++ ...ctions_ApplyConversionFunction_applied.res | 5 ++ ...nstantToPolyvariantConstructor_applied.res | 5 ++ ...ngConstantToVariantConstructor_applied.res | 5 ++ .../expected/Actions_UnusedOpen_applied.res | 5 ++ .../Actions_UnusedSwitchCase_applied.res | 5 ++ .../fixtures/Actions_ApplyCoercion.res | 5 ++ .../Actions_ApplyConversionFunction.res | 1 + ...StringConstantToPolyvariantConstructor.res | 8 +++ ...ons_StringConstantToVariantConstructor.res | 11 +++ .../actions/fixtures/Actions_UnusedOpen.res | 5 ++ .../fixtures/Actions_UnusedSwitchCase.res | 6 ++ tests/build_tests/actions/input.js | 72 +++++++++++++++++++ tools/bin/main.ml | 7 ++ tools/src/tools.ml | 52 ++++++++++++++ 25 files changed, 314 insertions(+), 7 deletions(-) create mode 100644 tests/build_tests/actions/ACTIONS_TESTS.md create mode 100644 tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_ApplyCoercion.res create mode 100644 tests/build_tests/actions/fixtures/Actions_ApplyConversionFunction.res create mode 100644 tests/build_tests/actions/fixtures/Actions_StringConstantToPolyvariantConstructor.res create mode 100644 tests/build_tests/actions/fixtures/Actions_StringConstantToVariantConstructor.res create mode 100644 tests/build_tests/actions/fixtures/Actions_UnusedOpen.res create mode 100644 tests/build_tests/actions/fixtures/Actions_UnusedSwitchCase.res create mode 100644 tests/build_tests/actions/input.js diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index ec40263bb67..dda286923fb 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -446,4 +446,6 @@ let _ : unit = exit 2 | x -> Location.report_exception ppf x; + (* Re-save cmt so we can get the possible actions *) + Cmt_format.resave_cmt_with_possible_actions (); exit 2 diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index ff30fc00435..ebb66742a23 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -64,6 +64,7 @@ type cmt_infos = { cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; cmt_extra_info: Cmt_utils.cmt_extra_info; + cmt_possible_actions : Cmt_utils.cmt_action list; } type error = @@ -156,11 +157,13 @@ let read_cmi filename = let saved_types = ref [] let value_deps = ref [] let deprecated_used = ref [] +let possible_actions = ref [] let clear () = saved_types := []; value_deps := []; - deprecated_used := [] + deprecated_used := []; + possible_actions := [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types @@ -178,6 +181,10 @@ let record_deprecated_used ?deprecated_context ?migration_template ?migration_in :: !deprecated_used let _ = Cmt_utils.record_deprecated_used := record_deprecated_used +let add_possible_action action = + possible_actions := action :: !possible_actions + +let _ = Cmt_utils._add_possible_action := add_possible_action let record_value_dependency vd1 vd2 = if vd1.Types.val_loc <> vd2.Types.val_loc then @@ -188,8 +195,30 @@ let save_cmt _filename _modname _binary_annots _sourcefile _initial_env _cmi = ( #else open Cmi_format +let current_cmt_filename = ref None + +(* TODO: Terrible hack. Figure out way to do this without saving the cmt file twice. + Probably change how/where we save the cmt, and delay it to after writing errors, if possible. +*) +let resave_cmt_with_possible_actions () = + if List.length !possible_actions > 0 then begin + match !current_cmt_filename with + | None -> () + | Some filename -> + let current_cmt = read_cmt filename in + Misc.output_to_bin_file_directly filename + (fun _temp_file_name oc -> + let cmt = { + current_cmt with + cmt_possible_actions = current_cmt.cmt_possible_actions @ !possible_actions; + } in + output_cmt oc cmt) + end; + clear () + let save_cmt filename modname binary_annots sourcefile initial_env cmi = if !Clflags.binary_annotations then begin + current_cmt_filename := Some filename; Misc.output_to_bin_file_directly filename (fun temp_file_name oc -> let this_crc = @@ -214,6 +243,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; cmt_extra_info = {deprecated_used = !deprecated_used}; + cmt_possible_actions = !possible_actions; } in output_cmt oc cmt) end; diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 66589f088de..634fdfc1127 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -64,6 +64,7 @@ type cmt_infos = { cmt_interface_digest: Digest.t option; cmt_use_summaries: bool; cmt_extra_info: Cmt_utils.cmt_extra_info; + cmt_possible_actions: Cmt_utils.cmt_action list; } type error = Not_a_typedtree of string @@ -119,6 +120,7 @@ val record_deprecated_used : Location.t -> string -> unit +val resave_cmt_with_possible_actions : unit -> unit (* diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 3e08cd93b47..c578ed58ec9 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -29,3 +29,15 @@ let record_deprecated_used : ignore deprecated_context; ignore migration_template; ignore migration_in_pipe_chain_template) +type action_type = + | ApplyFunction of {function_name: Longident.t} + | ApplyCoercion of {coerce_to_name: Longident.t} + | RemoveSwitchCase + | RemoveOpen + | ReplaceWithVariantConstructor of {constructor_name: Longident.t} + | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} + +type cmt_action = {loc: Location.t; action: action_type; description: string} + +let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) +let add_possible_action action = !_add_possible_action action diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 970634be03d..f3d04b0b608 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1891,7 +1891,9 @@ let open_signature ?(used_slot = ref false) ?(loc = Location.none) Delayed_checks.add_delayed_check (fun () -> if not !used then ( used := true; - Location.prerr_warning loc (Warnings.Unused_open (Path.name root)))); + Location.prerr_warning loc (Warnings.Unused_open (Path.name root)); + Cmt_utils.add_possible_action + {loc; action = RemoveOpen; description = "Remove open"})); let shadowed = ref [] in let slot s b = (match check_shadowing env b with diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 1805844fd96..1d313fcfb96 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -657,6 +657,15 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in match (reprinted, List.mem string_value variant_constructors) with | Some reprinted, true -> + Cmt_utils.add_possible_action + { + loc; + action = + ReplaceWithPolymorphicVariantConstructor + {constructor_name = string_value}; + description = + "Replace with polymorphic variant constructor " ^ string_value; + }; fprintf ppf "\n\n\ \ Possible solutions:\n\ @@ -715,6 +724,15 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in match reprinted with | Some reprinted -> + Cmt_utils.add_possible_action + { + loc; + action = + ReplaceWithVariantConstructor + {constructor_name = Longident.parse constructor_name}; + description = + "Replace with variant constructor " ^ constructor_name; + }; fprintf ppf "\n\n\ \ Possible solutions:\n\ @@ -772,6 +790,14 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in if can_show_coercion_message && not is_constant then ( + Cmt_utils.add_possible_action + { + loc; + action = + ApplyCoercion + {coerce_to_name = target_type_string |> Longident.parse}; + description = "Coerce to " ^ target_type_string; + }; fprintf ppf "@,\ @,\ diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 8d1fe66c70f..28d3ee29ab4 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2202,7 +2202,15 @@ let check_unused pred casel = | _ -> r in match r with - | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match + | Unused -> + Location.prerr_warning q.pat_loc Warnings.Unused_match; + (* TODO: Maybe move this into prerr_warning? *) + Cmt_utils.add_possible_action + { + loc = q.pat_loc; + action = RemoveSwitchCase; + description = "Remove switch case"; + } | Upartial ps -> ps |> List.filter (fun p -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ee304dff7d7..1fed3ee5eeb 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -698,9 +698,16 @@ let simple_conversions = (("string", "int"), "Int.fromString"); ] -let print_simple_conversion ppf (actual, expected) = +let print_simple_conversion ~loc ppf (actual, expected) = try let converter = List.assoc (actual, expected) simple_conversions in + Cmt_utils.add_possible_action + { + loc; + action = ApplyFunction {function_name = Longident.parse converter}; + description = Printf.sprintf "Convert to %s with %s" expected converter; + }; + fprintf ppf "@,\ @,\ @@ -719,14 +726,14 @@ let print_simple_message ppf = function @{20.@})." | _ -> () -let show_extra_help ppf _env trace = +let show_extra_help ~loc ppf _env trace = match bottom_aliases trace with | Some ( {Types.desc = Tconstr (actual_path, actual_args, _)}, {desc = Tconstr (expected_path, expexted_args, _)} ) -> ( match (actual_path, actual_args, expected_path, expexted_args) with | Pident {name = actual_name}, [], Pident {name = expected_name}, [] -> - print_simple_conversion ppf (actual_name, expected_name); + print_simple_conversion ~loc ppf (actual_name, expected_name); print_simple_message ppf (actual_name, expected_name) | _ -> ()) | _ -> () @@ -800,7 +807,7 @@ let print_expr_type_clash ~context env loc trace ppf = (function ppf -> error_expected_type_text ppf context); print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf bottom_aliases_result trace context; - show_extra_help ppf env trace + show_extra_help ~loc ppf env trace let report_arity_mismatch ~arity_a ~arity_b ppf = fprintf ppf diff --git a/lib_dev/process.js b/lib_dev/process.js index 0dbddd4881e..8a03aeacfac 100644 --- a/lib_dev/process.js +++ b/lib_dev/process.js @@ -176,6 +176,19 @@ export function setup(cwd = process.cwd()) { return exec(bsc_exe, args, options); }, + /** + * `rescript-tools` CLI + * + * @return {Promise} + */ + rescriptTools(command, args = [], options = {}) { + const cliPath = path.join( + import.meta.dirname, + "../cli/rescript-tools.js" + ); + return exec("node", [cliPath, command, ...args].filter(Boolean), options); + }, + /** * Execute ReScript `build` command directly * diff --git a/tests/build_tests/actions/ACTIONS_TESTS.md b/tests/build_tests/actions/ACTIONS_TESTS.md new file mode 100644 index 00000000000..c9d11ea0d92 --- /dev/null +++ b/tests/build_tests/actions/ACTIONS_TESTS.md @@ -0,0 +1,8 @@ +# Actions tests + +Tests for emitted possible actions. + +- Add ReScript files that should be producing actions to `tests/build_tests/actions/fixtures`. Make sure you prefix all filenames with `Actions_`, e.g `Actions_UnusedOpen.res` +- Test file output are emitted as actual ReScript files suffixed with `_applied`, into `tests/build_tests/actions/expected`. So `Actions_UnusedOpen_applied.res` +- Run `node tests/build_tests/actions/input.js` to run the tests +- Run `node tests/build_tests/actions/input.js update` to persist any updates to the test output, or write initial output for new tests diff --git a/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res new file mode 100644 index 00000000000..4ba8b400c5a --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 4, "character": 13}, "end": {"line": 4, "character": 15}}, + "description": "Coerce to x2", + "action": ApplyCoercion x2 + }] \ No newline at end of file diff --git a/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res new file mode 100644 index 00000000000..14d40822db9 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 0, "character": 13}, "end": {"line": 0, "character": 16}}, + "description": "Convert to int with Float.toInt", + "action": "ApplyFunction Float.toInt" + }] \ No newline at end of file diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res new file mode 100644 index 00000000000..67a9a9ea2e1 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 7, "character": 19}, "end": {"line": 7, "character": 24}}, + "description": "Replace with polymorphic variant constructor ONE", + "action": ReplaceWithPolymorphicVariantConstructor ONE + }] \ No newline at end of file diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res new file mode 100644 index 00000000000..b83a148553e --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 10, "character": 27}, "end": {"line": 10, "character": 35}}, + "description": "Replace with variant constructor Active", + "action": ReplaceWithVariantConstructor Active + }] \ No newline at end of file diff --git a/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res new file mode 100644 index 00000000000..c3da54ce391 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 4, "character": 0}, "end": {"line": 4, "character": 6}}, + "description": "Remove open", + "action": "RemoveOpen" + }] \ No newline at end of file diff --git a/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res new file mode 100644 index 00000000000..ad461b66f69 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res @@ -0,0 +1,5 @@ +[{ + "loc": {"start": {"line": 4, "character": 2}, "end": {"line": 4, "character": 3}}, + "description": "Remove switch case", + "action": "RemoveSwitchCase" + }] \ No newline at end of file diff --git a/tests/build_tests/actions/fixtures/Actions_ApplyCoercion.res b/tests/build_tests/actions/fixtures/Actions_ApplyCoercion.res new file mode 100644 index 00000000000..d841d248e01 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_ApplyCoercion.res @@ -0,0 +1,5 @@ +type x1 = One +type x2 = | ...x1 | Two + +let x1: x1 = One +let x2: x2 = x1 diff --git a/tests/build_tests/actions/fixtures/Actions_ApplyConversionFunction.res b/tests/build_tests/actions/fixtures/Actions_ApplyConversionFunction.res new file mode 100644 index 00000000000..674fb457697 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_ApplyConversionFunction.res @@ -0,0 +1 @@ +let x: int = 12. diff --git a/tests/build_tests/actions/fixtures/Actions_StringConstantToPolyvariantConstructor.res b/tests/build_tests/actions/fixtures/Actions_StringConstantToPolyvariantConstructor.res new file mode 100644 index 00000000000..d52a39ecaf7 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_StringConstantToPolyvariantConstructor.res @@ -0,0 +1,8 @@ +let doStuff = (a: int, b: [#ONE | #TWO]) => { + switch b { + | #ONE => a + 1 + | #TWO => a + 2 + } +} + +let x = doStuff(1, "ONE") diff --git a/tests/build_tests/actions/fixtures/Actions_StringConstantToVariantConstructor.res b/tests/build_tests/actions/fixtures/Actions_StringConstantToVariantConstructor.res new file mode 100644 index 00000000000..d3e7f5a6ecb --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_StringConstantToVariantConstructor.res @@ -0,0 +1,11 @@ +type status = Active | Inactive | Pending + +let processStatus = (s: status) => { + switch s { + | Active => "active" + | Inactive => "inactive" + | Pending => "pending" + } +} + +let result = processStatus("Active") diff --git a/tests/build_tests/actions/fixtures/Actions_UnusedOpen.res b/tests/build_tests/actions/fixtures/Actions_UnusedOpen.res new file mode 100644 index 00000000000..89670b250e0 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_UnusedOpen.res @@ -0,0 +1,5 @@ +module X = { + let doStuff = s => Console.log(s) +} + +open X diff --git a/tests/build_tests/actions/fixtures/Actions_UnusedSwitchCase.res b/tests/build_tests/actions/fixtures/Actions_UnusedSwitchCase.res new file mode 100644 index 00000000000..bfc62e529c1 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_UnusedSwitchCase.res @@ -0,0 +1,6 @@ +let x1 = switch Some(true) { +| Some(true) => 1 +| Some(false) => 2 +| None => 3 +| _ => 4 +} diff --git a/tests/build_tests/actions/input.js b/tests/build_tests/actions/input.js new file mode 100644 index 00000000000..71ee8d77386 --- /dev/null +++ b/tests/build_tests/actions/input.js @@ -0,0 +1,72 @@ +// @ts-check + +import { readdirSync } from "node:fs"; +import * as fs from "node:fs/promises"; +import * as path from "node:path"; +import { setup } from "#dev/process"; +import { normalizeNewlines } from "#dev/utils"; + +const { bsc, rescriptTools } = setup(import.meta.dirname); + +const expectedDir = path.join(import.meta.dirname, "expected"); + +const fixtures = readdirSync(path.join(import.meta.dirname, "fixtures")).filter( + (fileName) => path.extname(fileName) === ".res" +); + +const prefix = ["-w", "+A", "-bs-jsx", "4"]; + +const updateTests = process.argv[2] === "update"; + +/** + * @param {string} output + * @return {string} + */ +function postProcessErrorOutput(output) { + let result = output; + result = result.trimEnd(); + return normalizeNewlines(result); +} + +let doneTasksCount = 0; +let atLeastOneTaskFailed = false; + +for (const fileName of fixtures) { + const fullFilePath = path.join(import.meta.dirname, "fixtures", fileName); + const cmtPath = fullFilePath.replace(".res", ".cmt"); + await bsc([...prefix, "-color", "always", fullFilePath]); + const { stdout, stderr } = await rescriptTools("actions", [ + fullFilePath, + cmtPath, + ]); + if (stderr.length > 0) { + console.error(stderr.toString()); + } + doneTasksCount++; + const expectedFilePath = path.join( + expectedDir, + `${fileName.replace(".res", "")}_applied.res` + ); + const actualActions = postProcessErrorOutput(stdout.toString()); + if (updateTests) { + await fs.writeFile(expectedFilePath, actualActions); + } else { + const expectedActions = postProcessErrorOutput( + await fs.readFile(expectedFilePath, "utf-8") + ); + if (expectedActions !== actualActions) { + console.error( + `The old and new actions for the test ${fullFilePath} aren't the same` + ); + console.error("\n=== Old:"); + console.error(expectedActions); + console.error("\n=== New:"); + console.error(actualActions); + atLeastOneTaskFailed = true; + } + + if (doneTasksCount === fixtures.length && atLeastOneTaskFailed) { + process.exit(1); + } + } +} diff --git a/tools/bin/main.ml b/tools/bin/main.ml index cd810b53095..62eb7a1bd81 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -177,6 +177,13 @@ let main () = done; Sys.argv.(len - 1) <- ""; Reanalyze.cli () + | "actions" :: file :: opts -> + let cmtPath = + match opts with + | path :: _ when String.ends_with ~suffix:".cmt" path -> Some path + | _ -> None + in + Tools.Actions.extractActionsFromFile ?cmtPath file | "extract-embedded" :: extPointNames :: filename :: _ -> logAndExit (Ok diff --git a/tools/src/tools.ml b/tools/src/tools.ml index eb591aa9123..662541e9e1a 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1294,3 +1294,55 @@ module ExtractCodeblocks = struct end module Migrate = Migrate +module Actions = struct + let extractActionsFromFile ?cmtPath entryPointFile = + let path = + match Filename.is_relative entryPointFile with + | true -> Unix.realpath entryPointFile + | false -> entryPointFile + in + let loadedCmt = + match cmtPath with + | None -> Cmt.loadCmtInfosFromPath ~path + | Some path -> Shared.tryReadCmt path + in + match loadedCmt with + | None -> + Printf.printf + "error: failed to extract actions for %s because build artifacts could \ + not be found. try to build the project" + path + | Some {cmt_possible_actions} -> + cmt_possible_actions + |> List.map (fun (action : Cmt_utils.cmt_action) -> + let range = Loc.rangeOfLoc action.loc in + Protocol.stringifyObject + [ + ("loc", Some (Protocol.stringifyRange range)); + ("description", Some (Protocol.wrapInQuotes action.description)); + ( "action", + Some + (match action.action with + | ApplyFunction {function_name} -> + Protocol.wrapInQuotes + ("ApplyFunction " + ^ (function_name |> Longident.flatten + |> String.concat ".")) + | ApplyCoercion {coerce_to_name} -> + "ApplyCoercion " + ^ (coerce_to_name |> Longident.flatten + |> String.concat ".") + | RemoveSwitchCase -> + Protocol.wrapInQuotes "RemoveSwitchCase" + | RemoveOpen -> Protocol.wrapInQuotes "RemoveOpen" + | ReplaceWithVariantConstructor {constructor_name} -> + "ReplaceWithVariantConstructor " + ^ (constructor_name |> Longident.flatten + |> String.concat ".") + | ReplaceWithPolymorphicVariantConstructor + {constructor_name} -> + "ReplaceWithPolymorphicVariantConstructor " + ^ constructor_name) ); + ]) + |> Protocol.array |> print_endline +end From 3558f3ad826e7f5bcbeaf95cd1c88feb4074f1ba Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:04:17 +0200 Subject: [PATCH 02/44] implement the actual rewriting --- lib_dev/process.js | 2 +- .../Actions_ApplyCoercion_applied.res | 10 +- ...ctions_ApplyConversionFunction_applied.res | 6 +- ...nstantToPolyvariantConstructor_applied.res | 13 +- ...ngConstantToVariantConstructor_applied.res | 16 +- .../expected/Actions_UnusedOpen_applied.res | 8 +- .../Actions_UnusedSwitchCase_applied.res | 10 +- tests/build_tests/actions/input.js | 11 +- tools/bin/main.ml | 4 +- tools/src/tools.ml | 138 ++++++++++++++++++ 10 files changed, 181 insertions(+), 37 deletions(-) diff --git a/lib_dev/process.js b/lib_dev/process.js index 8a03aeacfac..af2d4caf24d 100644 --- a/lib_dev/process.js +++ b/lib_dev/process.js @@ -184,7 +184,7 @@ export function setup(cwd = process.cwd()) { rescriptTools(command, args = [], options = {}) { const cliPath = path.join( import.meta.dirname, - "../cli/rescript-tools.js" + "../cli/rescript-tools.js", ); return exec("node", [cliPath, command, ...args].filter(Boolean), options); }, diff --git a/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res index 4ba8b400c5a..0d3e13f2d09 100644 --- a/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res +++ b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res @@ -1,5 +1,5 @@ -[{ - "loc": {"start": {"line": 4, "character": 13}, "end": {"line": 4, "character": 15}}, - "description": "Coerce to x2", - "action": ApplyCoercion x2 - }] \ No newline at end of file +type x1 = One +type x2 = | ...x1 | Two + +let x1: x1 = One +let x2: x2 = (x1 :> x2) diff --git a/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res index 14d40822db9..c197469c741 100644 --- a/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res +++ b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res @@ -1,5 +1 @@ -[{ - "loc": {"start": {"line": 0, "character": 13}, "end": {"line": 0, "character": 16}}, - "description": "Convert to int with Float.toInt", - "action": "ApplyFunction Float.toInt" - }] \ No newline at end of file +let x: int = Float.toInt(12.) diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res index 67a9a9ea2e1..8e5c1faaf03 100644 --- a/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res +++ b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res @@ -1,5 +1,8 @@ -[{ - "loc": {"start": {"line": 7, "character": 19}, "end": {"line": 7, "character": 24}}, - "description": "Replace with polymorphic variant constructor ONE", - "action": ReplaceWithPolymorphicVariantConstructor ONE - }] \ No newline at end of file +let doStuff = (a: int, b: [#ONE | #TWO]) => { + switch b { + | #ONE => a + 1 + | #TWO => a + 2 + } +} + +let x = doStuff(1, #ONE) diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res index b83a148553e..9bde3d17d57 100644 --- a/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res +++ b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res @@ -1,5 +1,11 @@ -[{ - "loc": {"start": {"line": 10, "character": 27}, "end": {"line": 10, "character": 35}}, - "description": "Replace with variant constructor Active", - "action": ReplaceWithVariantConstructor Active - }] \ No newline at end of file +type status = Active | Inactive | Pending + +let processStatus = (s: status) => { + switch s { + | Active => "active" + | Inactive => "inactive" + | Pending => "pending" + } +} + +let result = processStatus(Active) diff --git a/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res index c3da54ce391..f5e64001137 100644 --- a/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res +++ b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res @@ -1,5 +1,3 @@ -[{ - "loc": {"start": {"line": 4, "character": 0}, "end": {"line": 4, "character": 6}}, - "description": "Remove open", - "action": "RemoveOpen" - }] \ No newline at end of file +module X = { + let doStuff = s => Console.log(s) +} diff --git a/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res index ad461b66f69..9ff0ec466fc 100644 --- a/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res +++ b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res @@ -1,5 +1,5 @@ -[{ - "loc": {"start": {"line": 4, "character": 2}, "end": {"line": 4, "character": 3}}, - "description": "Remove switch case", - "action": "RemoveSwitchCase" - }] \ No newline at end of file +let x1 = switch Some(true) { +| Some(true) => 1 +| Some(false) => 2 +| None => 3 +} diff --git a/tests/build_tests/actions/input.js b/tests/build_tests/actions/input.js index 71ee8d77386..5f228350a60 100644 --- a/tests/build_tests/actions/input.js +++ b/tests/build_tests/actions/input.js @@ -11,7 +11,7 @@ const { bsc, rescriptTools } = setup(import.meta.dirname); const expectedDir = path.join(import.meta.dirname, "expected"); const fixtures = readdirSync(path.join(import.meta.dirname, "fixtures")).filter( - (fileName) => path.extname(fileName) === ".res" + fileName => path.extname(fileName) === ".res", ); const prefix = ["-w", "+A", "-bs-jsx", "4"]; @@ -24,7 +24,7 @@ const updateTests = process.argv[2] === "update"; */ function postProcessErrorOutput(output) { let result = output; - result = result.trimEnd(); + result = result.trimEnd() + "\n"; return normalizeNewlines(result); } @@ -38,6 +38,7 @@ for (const fileName of fixtures) { const { stdout, stderr } = await rescriptTools("actions", [ fullFilePath, cmtPath, + "--runAll", ]); if (stderr.length > 0) { console.error(stderr.toString()); @@ -45,18 +46,18 @@ for (const fileName of fixtures) { doneTasksCount++; const expectedFilePath = path.join( expectedDir, - `${fileName.replace(".res", "")}_applied.res` + `${fileName.replace(".res", "")}_applied.res`, ); const actualActions = postProcessErrorOutput(stdout.toString()); if (updateTests) { await fs.writeFile(expectedFilePath, actualActions); } else { const expectedActions = postProcessErrorOutput( - await fs.readFile(expectedFilePath, "utf-8") + await fs.readFile(expectedFilePath, "utf-8"), ); if (expectedActions !== actualActions) { console.error( - `The old and new actions for the test ${fullFilePath} aren't the same` + `The old and new actions for the test ${fullFilePath} aren't the same`, ); console.error("\n=== Old:"); console.error(expectedActions); diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 62eb7a1bd81..ae3759e2e04 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -178,12 +178,14 @@ let main () = Sys.argv.(len - 1) <- ""; Reanalyze.cli () | "actions" :: file :: opts -> + let run_all_on_file = List.mem "--runAll" opts in let cmtPath = match opts with | path :: _ when String.ends_with ~suffix:".cmt" path -> Some path | _ -> None in - Tools.Actions.extractActionsFromFile ?cmtPath file + if run_all_on_file then Tools.Actions.runActionsOnFile ?cmtPath file + else Tools.Actions.extractActionsFromFile ?cmtPath file | "extract-embedded" :: extPointNames :: filename :: _ -> logAndExit (Ok diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 662541e9e1a..0b266a03621 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1295,6 +1295,144 @@ end module Migrate = Migrate module Actions = struct + let applyActionsToFile path actions = + let mapper = + { + Ast_mapper.default_mapper with + structure = + (fun mapper items -> + let items = + items + |> List.filter_map (fun (str_item : Parsetree.structure_item) -> + match str_item.pstr_desc with + | Pstr_open _ -> ( + let remove_open_action = + actions + |> List.find_opt + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveOpen -> action.loc = str_item.pstr_loc + | _ -> false) + in + match remove_open_action with + | Some _ -> None + | None -> Some str_item) + | _ -> Some str_item) + in + Ast_mapper.default_mapper.structure mapper items); + cases = + (fun mapper cases -> + let cases = + cases + |> List.filter_map (fun (case : Parsetree.case) -> + let remove_case_action = + actions + |> List.find_opt (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveSwitchCase -> + action.loc = case.pc_lhs.ppat_loc + | _ -> false) + in + match remove_case_action with + | Some _ -> None + | None -> Some case) + in + Ast_mapper.default_mapper.cases mapper cases); + expr = + (fun mapper expr -> + let mapped_expr = + actions + |> List.find_map (fun (action : Cmt_utils.cmt_action) -> + if action.loc = expr.pexp_loc then + match action.action with + | ReplaceWithVariantConstructor {constructor_name} -> + Some + { + expr with + pexp_desc = + Pexp_construct + (Location.mknoloc constructor_name, None); + } + | ReplaceWithPolymorphicVariantConstructor + {constructor_name} -> + Some + { + expr with + pexp_desc = Pexp_variant (constructor_name, None); + } + | ApplyFunction {function_name} -> + Some + { + expr with + pexp_desc = + Pexp_apply + { + funct = + Ast_helper.Exp.ident + (Location.mknoloc function_name); + args = [(Nolabel, expr)]; + partial = false; + transformed_jsx = false; + }; + } + | ApplyCoercion {coerce_to_name} -> + Some + { + expr with + pexp_desc = + Pexp_coerce + ( expr, + (), + Ast_helper.Typ.constr + (Location.mknoloc coerce_to_name) + [] ); + } + | _ -> None + else None) + in + match mapped_expr with + | None -> Ast_mapper.default_mapper.expr mapper expr + | Some expr -> expr); + } + in + if Filename.check_suffix path ".res" then + let parser = + Res_driver.parsing_engine.parse_implementation ~for_printer:true + in + let {Res_driver.parsetree; comments} = parser ~filename:path in + let ast_mapped = mapper.structure mapper parsetree in + Ok (Res_printer.print_implementation ast_mapped ~comments) + else + (* TODO: Handle .resi? *) + Error + (Printf.sprintf + "error: failed to apply actions to %s because it is not a .res file" + path) + + let runActionsOnFile ?cmtPath entryPointFile = + let path = + match Filename.is_relative entryPointFile with + | true -> Unix.realpath entryPointFile + | false -> entryPointFile + in + let loadedCmt = + match cmtPath with + | None -> Cmt.loadCmtInfosFromPath ~path + | Some path -> Shared.tryReadCmt path + in + match loadedCmt with + | None -> + Printf.printf + "error: failed to run actions on %s because build artifacts could not \ + be found. try to build the project" + path + | Some {cmt_possible_actions} -> ( + match applyActionsToFile path cmt_possible_actions with + | Ok applied -> print_endline applied + | Error e -> + print_endline e; + exit 1) + let extractActionsFromFile ?cmtPath entryPointFile = let path = match Filename.is_relative entryPointFile with From 6991578776123d3c30e7d41416426ec3669e359d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:05:36 +0200 Subject: [PATCH 03/44] map --- tools/src/tools.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 0b266a03621..91b9d173f42 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1344,6 +1344,7 @@ module Actions = struct actions |> List.find_map (fun (action : Cmt_utils.cmt_action) -> if action.loc = expr.pexp_loc then + let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with | ReplaceWithVariantConstructor {constructor_name} -> Some From 3bee823ed4cf096f9d67ace9502526d95cdc0dc5 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:16:58 +0200 Subject: [PATCH 04/44] add and remove await --- compiler/ml/cmt_utils.ml | 2 + compiler/ml/error_message_utils.ml | 5 ++ .../expected/Actions_AddAwait_applied.res | 5 ++ .../expected/Actions_RemoveAwait_applied.res | 2 + .../actions/fixtures/Actions_AddAwait.res | 5 ++ .../actions/fixtures/Actions_RemoveAwait.res | 2 + tests/build_tests/actions/input.js | 2 + tools/src/tools.ml | 46 +++++-------------- 8 files changed, 35 insertions(+), 34 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_AddAwait_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_AddAwait.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveAwait.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index c578ed58ec9..12345d5d332 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -34,6 +34,8 @@ type action_type = | ApplyCoercion of {coerce_to_name: Longident.t} | RemoveSwitchCase | RemoveOpen + | RemoveAwait + | AddAwait | ReplaceWithVariantConstructor of {constructor_name: Longident.t} | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 1d313fcfb96..7db72503300 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -389,6 +389,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf \ To fix this, change the highlighted code so it evaluates to a \ @{bool@}." | Some Await, _ -> + Cmt_utils.add_possible_action + {loc; action = RemoveAwait; description = "Remove await"}; fprintf ppf "\n\n\ \ You're trying to await something that is not a promise.\n\n\ @@ -487,6 +489,9 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | None -> "") | _, Some ({Types.desc = Tconstr (p1, _, _)}, _) when Path.same p1 Predef.path_promise -> + (* TODO: This should be aware of if we're in an async context or not? *) + Cmt_utils.add_possible_action + {loc; action = AddAwait; description = "Await promise"}; fprintf ppf "\n\n - Did you mean to await this promise before using it?\n" | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _}) when Path.same p1 Predef.path_array -> diff --git a/tests/build_tests/actions/expected/Actions_AddAwait_applied.res b/tests/build_tests/actions/expected/Actions_AddAwait_applied.res new file mode 100644 index 00000000000..3aab13b1c0e --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_AddAwait_applied.res @@ -0,0 +1,5 @@ +let fn = async () => 12 + +let other = async (): int => { + await fn() +} diff --git a/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res b/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res new file mode 100644 index 00000000000..caf49c133c8 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res @@ -0,0 +1,2 @@ +let f = 12 +let x = f diff --git a/tests/build_tests/actions/fixtures/Actions_AddAwait.res b/tests/build_tests/actions/fixtures/Actions_AddAwait.res new file mode 100644 index 00000000000..51247f6c6c6 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_AddAwait.res @@ -0,0 +1,5 @@ +let fn = async () => 12 + +let other = async (): int => { + fn() +} diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveAwait.res b/tests/build_tests/actions/fixtures/Actions_RemoveAwait.res new file mode 100644 index 00000000000..fda89aa4009 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveAwait.res @@ -0,0 +1,2 @@ +let f = 12 +let x = await f diff --git a/tests/build_tests/actions/input.js b/tests/build_tests/actions/input.js index 5f228350a60..3b7cb68ded5 100644 --- a/tests/build_tests/actions/input.js +++ b/tests/build_tests/actions/input.js @@ -71,3 +71,5 @@ for (const fileName of fixtures) { } } } + +// TODO: Check that the emitted files compile. diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 91b9d173f42..3f722590037 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1343,9 +1343,12 @@ module Actions = struct let mapped_expr = actions |> List.find_map (fun (action : Cmt_utils.cmt_action) -> + (* When the loc is the expr itself *) if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | AddAwait -> + Some {expr with pexp_desc = Pexp_await expr} | ReplaceWithVariantConstructor {constructor_name} -> Some { @@ -1389,7 +1392,12 @@ module Actions = struct [] ); } | _ -> None - else None) + else + (* Other cases when the loc is on something else in the expr *) + match expr.pexp_desc with + | Pexp_await inner when inner.pexp_loc = action.loc -> + Some inner + | _ -> None) in match mapped_expr with | None -> Ast_mapper.default_mapper.expr mapper expr @@ -1451,37 +1459,7 @@ module Actions = struct "error: failed to extract actions for %s because build artifacts could \ not be found. try to build the project" path - | Some {cmt_possible_actions} -> - cmt_possible_actions - |> List.map (fun (action : Cmt_utils.cmt_action) -> - let range = Loc.rangeOfLoc action.loc in - Protocol.stringifyObject - [ - ("loc", Some (Protocol.stringifyRange range)); - ("description", Some (Protocol.wrapInQuotes action.description)); - ( "action", - Some - (match action.action with - | ApplyFunction {function_name} -> - Protocol.wrapInQuotes - ("ApplyFunction " - ^ (function_name |> Longident.flatten - |> String.concat ".")) - | ApplyCoercion {coerce_to_name} -> - "ApplyCoercion " - ^ (coerce_to_name |> Longident.flatten - |> String.concat ".") - | RemoveSwitchCase -> - Protocol.wrapInQuotes "RemoveSwitchCase" - | RemoveOpen -> Protocol.wrapInQuotes "RemoveOpen" - | ReplaceWithVariantConstructor {constructor_name} -> - "ReplaceWithVariantConstructor " - ^ (constructor_name |> Longident.flatten - |> String.concat ".") - | ReplaceWithPolymorphicVariantConstructor - {constructor_name} -> - "ReplaceWithPolymorphicVariantConstructor " - ^ constructor_name) ); - ]) - |> Protocol.array |> print_endline + | Some _ -> + (* TODO *) + () end From b8e703a74b71f0289e08b8d44ac1604c0da974bb Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:21:49 +0200 Subject: [PATCH 05/44] rewrite object to record --- compiler/ml/cmt_utils.ml | 1 + compiler/ml/error_message_utils.ml | 6 ++++++ .../Actions_RewriteObjectToRecord_applied.res | 4 ++++ .../Actions_RewriteObjectToRecord.res | 4 ++++ tools/src/tools.ml | 19 +++++++++++++++++++ 5 files changed, 34 insertions(+) create mode 100644 tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RewriteObjectToRecord.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 12345d5d332..05ed2275d1e 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -38,6 +38,7 @@ type action_type = | AddAwait | ReplaceWithVariantConstructor of {constructor_name: Longident.t} | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} + | RewriteObjectToRecord type cmt_action = {loc: Location.t; action: action_type; description: string} diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 7db72503300..1857377baee 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -476,6 +476,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf Some record | _ -> None) in + Cmt_utils.add_possible_action + { + loc; + action = RewriteObjectToRecord; + description = "Rewrite object to record"; + }; fprintf ppf "@,\ @,\ diff --git a/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res b/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res new file mode 100644 index 00000000000..3f7d7b2c63f --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res @@ -0,0 +1,4 @@ +type x = {one: bool} +type xx = array + +let x: xx = [{one: true}] diff --git a/tests/build_tests/actions/fixtures/Actions_RewriteObjectToRecord.res b/tests/build_tests/actions/fixtures/Actions_RewriteObjectToRecord.res new file mode 100644 index 00000000000..1451c3f3d82 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RewriteObjectToRecord.res @@ -0,0 +1,4 @@ +type x = {one: bool} +type xx = array + +let x: xx = [{"one": true}] diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 3f722590037..487c315762d 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1347,6 +1347,25 @@ module Actions = struct if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | RewriteObjectToRecord -> ( + match expr with + | { + pexp_desc = + Pexp_extension + ( {txt = "obj"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ( ({pexp_desc = Pexp_record _} as + record), + _ ); + }; + ] ); + } -> + Some record + | _ -> None) | AddAwait -> Some {expr with pexp_desc = Pexp_await expr} | ReplaceWithVariantConstructor {constructor_name} -> From c99334a25a80f7628b584f10a6044bf500521d8f Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:28:26 +0200 Subject: [PATCH 06/44] rewrite array to tuple --- compiler/ml/cmt_utils.ml | 1 + compiler/ml/error_message_utils.ml | 2 ++ .../Actions_RewriteArrayToTuple_applied.res | 1 + .../fixtures/Actions_RewriteArrayToTuple.res | 1 + tools/src/tools.ml | 23 ++++++++++++++++--- 5 files changed, 25 insertions(+), 3 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 05ed2275d1e..67a7d87d420 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -39,6 +39,7 @@ type action_type = | ReplaceWithVariantConstructor of {constructor_name: Longident.t} | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} | RewriteObjectToRecord + | RewriteArrayToTuple type cmt_action = {loc: Location.t; action: action_type; description: string} diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 1857377baee..5d8d0e8bc75 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -417,6 +417,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | Some ComparisonOperator, _ -> fprintf ppf "\n\n You can only compare things of the same type." | Some ArrayValue, _ -> + Cmt_utils.add_possible_action + {loc; action = RewriteArrayToTuple; description = "Rewrite to tuple"}; fprintf ppf "\n\n\ \ Arrays can only contain items of the same type.\n\n\ diff --git a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res new file mode 100644 index 00000000000..29fe44ad724 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res @@ -0,0 +1 @@ +let x = (1, 2, "hello") diff --git a/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple.res b/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple.res new file mode 100644 index 00000000000..541be0e3ce9 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple.res @@ -0,0 +1 @@ +let x = [1, 2, "hello"] diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 487c315762d..f8411869196 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1413,9 +1413,26 @@ module Actions = struct | _ -> None else (* Other cases when the loc is on something else in the expr *) - match expr.pexp_desc with - | Pexp_await inner when inner.pexp_loc = action.loc -> - Some inner + match (expr.pexp_desc, action.action) with + | Pexp_await inner, RemoveAwait + when inner.pexp_loc = action.loc -> + Some (Ast_mapper.default_mapper.expr mapper inner) + | Pexp_array items, RewriteArrayToTuple + when items + |> List.find_opt + (fun (item : Parsetree.expression) -> + item.pexp_loc = action.loc) + |> Option.is_some -> + Some + { + expr with + pexp_desc = + Pexp_tuple + (items + |> List.map (fun item -> + Ast_mapper.default_mapper.expr mapper + item)); + } | _ -> None) in match mapped_expr with From 7a33916230aef6ce0617f0920a545538eefc2b10 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:33:59 +0200 Subject: [PATCH 07/44] more array to tuple --- compiler/ml/error_message_utils.ml | 6 ++++++ .../expected/Actions_RewriteArrayToTuple2_applied.res | 5 +++++ .../actions/fixtures/Actions_RewriteArrayToTuple2.res | 5 +++++ tools/src/tools.ml | 6 ++++++ 4 files changed, 22 insertions(+) create mode 100644 tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple2.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 5d8d0e8bc75..c4398b34989 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -507,6 +507,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> match exp.Parsetree.pexp_desc with | Pexp_array items -> + Cmt_utils.add_possible_action + { + loc; + action = RewriteArrayToTuple; + description = "Rewrite to tuple"; + }; Some {exp with Parsetree.pexp_desc = Pexp_tuple items} | _ -> None) in diff --git a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res new file mode 100644 index 00000000000..041f6910bbb --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res @@ -0,0 +1,5 @@ +let doStuff = ((one, two)) => { + one ++ two +} + +let x = doStuff(("hello", "world")) diff --git a/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple2.res b/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple2.res new file mode 100644 index 00000000000..4b203b92cee --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RewriteArrayToTuple2.res @@ -0,0 +1,5 @@ +let doStuff = ((one, two)) => { + one ++ two +} + +let x = doStuff(["hello", "world"]) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index f8411869196..fb824d4003f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1347,6 +1347,11 @@ module Actions = struct if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | RewriteArrayToTuple -> ( + match expr with + | {pexp_desc = Pexp_array items} -> + Some {expr with pexp_desc = Pexp_tuple items} + | _ -> None) | RewriteObjectToRecord -> ( match expr with | { @@ -1423,6 +1428,7 @@ module Actions = struct (fun (item : Parsetree.expression) -> item.pexp_loc = action.loc) |> Option.is_some -> + (* When the loc is on an item in the array *) Some { expr with From 81f8eb76c1ab09bf9ecb9490e4f8310f251b5e59 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:43:31 +0200 Subject: [PATCH 08/44] jsx conversions --- compiler/ml/error_message_utils.ml | 7 ++++++ ...ons_JSXCustomComponentChildren_applied.res | 24 +++++++++++++++++++ .../Actions_JSXCustomComponentChildren.res | 24 +++++++++++++++++++ tools/src/tools.ml | 17 ++++++++++++- 4 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_JSXCustomComponentChildren.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index c4398b34989..1f42d6b964f 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -538,6 +538,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in let print_jsx_msg ?(extra = "") name target_fn = + Cmt_utils.add_possible_action + { + loc; + action = ApplyFunction {function_name = Longident.parse target_fn}; + description = Printf.sprintf "Convert to %s with %s" name target_fn; + }; fprintf ppf "@,\ @,\ @@ -554,6 +560,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | _ when Path.same p Predef.path_float -> print_jsx_msg "float" (with_configured_jsx_module "float") | [_] when Path.same p Predef.path_option -> + (* TODO(actions) Unwrap action? *) fprintf ppf "@,\ @,\ diff --git a/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res b/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res new file mode 100644 index 00000000000..7e2793ec416 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res @@ -0,0 +1,24 @@ +@@config({ + flags: ["-bs-jsx", "4"], +}) + +module React = { + type element = Jsx.element + type componentLike<'props, 'return> = 'props => 'return + type component<'props> = Jsx.component<'props> + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + type fragmentProps = {children?: element} + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" +} + +module CustomComponent = { + @react.component + let make = (~children) => { + <> {children} + } +} + +let x = {React.float(1.)} diff --git a/tests/build_tests/actions/fixtures/Actions_JSXCustomComponentChildren.res b/tests/build_tests/actions/fixtures/Actions_JSXCustomComponentChildren.res new file mode 100644 index 00000000000..b4059e242b6 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_JSXCustomComponentChildren.res @@ -0,0 +1,24 @@ +@@config({ + flags: ["-bs-jsx", "4"], +}) + +module React = { + type element = Jsx.element + type componentLike<'props, 'return> = 'props => 'return + type component<'props> = Jsx.component<'props> + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + type fragmentProps = {children?: element} + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" +} + +module CustomComponent = { + @react.component + let make = (~children) => { + <> {children} + } +} + +let x = {1.} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index fb824d4003f..97cbeed60e9 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1340,6 +1340,7 @@ module Actions = struct Ast_mapper.default_mapper.cases mapper cases); expr = (fun mapper expr -> + (* TODO: Must account for pipe chains *) let mapped_expr = actions |> List.find_map (fun (action : Cmt_utils.cmt_action) -> @@ -1398,7 +1399,21 @@ module Actions = struct funct = Ast_helper.Exp.ident (Location.mknoloc function_name); - args = [(Nolabel, expr)]; + args = + [ + (* Remove any existing braces. Makes the output prettier. *) + ( Nolabel, + { + expr with + pexp_attributes = + expr.pexp_attributes + |> List.filter + (fun + (({txt}, _) : + Parsetree.attribute) + -> txt <> "res.braces"); + } ); + ]; partial = false; transformed_jsx = false; }; From c800f057e0f24ecad455ddb4cd6e8edd87163608 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:59:55 +0200 Subject: [PATCH 09/44] comments + rewrite ident --- compiler/ml/cmt_utils.ml | 1 + compiler/ml/error_message_utils.ml | 5 +++++ compiler/ml/typecore.ml | 17 ++++++++++++++++- .../expected/Actions_RewriteIdent_applied.res | 1 + .../actions/fixtures/Actions_RewriteIdent.res | 1 + tools/src/tools.ml | 10 ++++++++++ 6 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RewriteIdent.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 67a7d87d420..bfb854e254f 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -40,6 +40,7 @@ type action_type = | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} | RewriteObjectToRecord | RewriteArrayToTuple + | RewriteIdent of {new_ident: Longident.t} type cmt_action = {loc: Location.t; action: action_type; description: string} diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 1f42d6b964f..5ad22f41cc8 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -589,6 +589,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (RecordField {optional = true; field_name; jsx = None}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> + (* TODO(actions) Prepend with `?` *) fprintf ppf "@,\ @,\ @@ -607,6 +608,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (RecordField {optional = true; field_name; jsx = Some _}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> + (* TODO(actions) Prepend with `?` *) fprintf ppf "@,\ @,\ @@ -625,6 +627,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (FunctionArgument {optional = true}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> + (* TODO(actions) Prepend with `?` *) fprintf ppf "@,\ @,\ @@ -901,6 +904,7 @@ let print_contextual_unification_error ppf t1 t2 = | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p1 Predef.path_option && Path.same p2 Predef.path_option <> true -> + (* TODO(actions) Remove `Some`/`None` *) fprintf ppf "@,\ @\n\ @@ -911,6 +915,7 @@ let print_contextual_unification_error ppf t1 t2 = | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p2 Predef.path_option && Path.same p1 Predef.path_option <> true -> + (* TODO(actions) Add `Some` *) fprintf ppf "@,\ @\n\ diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 1fed3ee5eeb..7147573b8bf 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4381,6 +4381,7 @@ let report_error env loc ppf error = (* modified *) let is_inline_record = Option.is_some constuctor.cstr_inlined in if is_inline_record && expected = 1 then + (* TODO(actions) Add empty inline record argument, or change to inline record *) fprintf ppf "@[This variant constructor @{%a@} expects an inline record as \ payload%s.@]" @@ -4388,6 +4389,7 @@ let report_error env loc ppf error = (if provided = 0 then ", but it's not being passed any arguments" else "") else + (* TODO(actions) Add missing arguments *) fprintf ppf "@[This variant constructor @{%a@} expects %i %s, but it's%s \ being passed %i.@]" @@ -4477,6 +4479,7 @@ let report_error env loc ppf error = | Apply_wrong_label (l, ty) -> let print_message ppf = function | Nolabel -> + (* ?TODO(actions) Make labelled *) fprintf ppf "The argument at this position should be labelled." | l -> fprintf ppf "This function does not take the argument @{%s@}." @@ -4493,6 +4496,7 @@ let report_error env loc ppf error = | Label_multiply_defined {label} -> fprintf ppf "The record field label %s is defined several times" label | Labels_missing {labels; jsx_component_info = Some jsx_component_info} -> + (* TODO(actions) Add missing JSX props *) print_component_labels_missing_error ppf labels jsx_component_info | Labels_missing {labels} -> let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in @@ -4715,6 +4719,7 @@ let report_error env loc ppf error = if not is_fallback then fprintf ppf "@,"; if List.length missing_required_args > 0 then ( + (* TODO(actions) Add missing arguments *) fprintf ppf "@,- Missing arguments that must be provided: %s" (missing_required_args |> List.map (fun v -> "~" ^ v) @@ -4727,6 +4732,7 @@ let report_error env loc ppf error = Example: @{yourFn(~arg1=someVar, ...)@}"); if List.length superfluous_args > 0 then + (* TODO(actions) Remove arguments *) fprintf ppf "@,- Called with arguments it does not take: %s" (superfluous_args |> String.concat ", "); @@ -4773,25 +4779,34 @@ let report_error env loc ppf error = match suggestion with | None -> () | Some suggestion_str -> + Cmt_utils.add_possible_action + { + loc; + action = RewriteIdent {new_ident = Longident.parse suggestion_str}; + description = Printf.sprintf "Rewrite to use %s" suggestion_str; + }; fprintf ppf "@,@,Hint: Try @{%s@} instead (takes @{%d@} argument%s)." suggestion_str args (if args = 1 then "" else "s")) | None -> ()); - fprintf ppf "@]" | Field_not_optional (name, typ) -> + (* TODO(actions) Remove `?` *) fprintf ppf "Field @{%s@} is not optional in type %a. Use without ?" name type_expr typ | Type_params_not_supported lid -> + (* TODO(actions) Remove type parameters *) fprintf ppf "The type %a@ has type parameters, but type parameters is not supported \ here." longident lid | Field_access_on_dict_type -> + (* TODO(actions) Rewrite to Dict.get *) fprintf ppf "Direct field access on a dict is not supported. Use Dict.get instead." | Jsx_not_enabled -> + (* ?TODO(actions) Add JSX config to rescript.json...? *) fprintf ppf "Cannot compile JSX expression because JSX support is not enabled. Add \ \"jsx\" settings to rescript.json to enable JSX support." diff --git a/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res b/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res new file mode 100644 index 00000000000..5fbfedf4167 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res @@ -0,0 +1 @@ +Console.log("hello") diff --git a/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res b/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res new file mode 100644 index 00000000000..5f9073f699d --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res @@ -0,0 +1 @@ +Console.log2("hello") \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 97cbeed60e9..9b019254e11 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1348,6 +1348,16 @@ module Actions = struct if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | RewriteIdent {new_ident} -> ( + match expr with + | {pexp_desc = Pexp_ident ident} -> + Some + { + expr with + pexp_desc = + Pexp_ident {ident with txt = new_ident}; + } + | _ -> None) | RewriteArrayToTuple -> ( match expr with | {pexp_desc = Pexp_array items} -> From 7e3d48c6bf47f4a18a75485e80656527a72c4ef4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 20:41:42 +0200 Subject: [PATCH 10/44] more todo comments for actions that could be useful --- compiler/ext/warnings.ml | 27 ++++++++++++++++++++++----- compiler/ml/parmatch.ml | 2 ++ compiler/ml/typecore.ml | 2 ++ compiler/syntax/src/res_core.ml | 1 + 4 files changed, 27 insertions(+), 5 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index f25b91b4f89..b792054dd72 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -388,6 +388,8 @@ let message = function "this pattern-matching is not exhaustive.\n\ All clauses in this pattern-matching are guarded." | Unused_var v | Unused_var_strict v -> + (* TODO(actions) Prefix with `_` *) + (* TODO(actions) Remove variable *) Format.sprintf "unused variable %s.\n\n\ Fix this by:\n\ @@ -403,11 +405,17 @@ let message = function | Duplicate_definitions (kind, cname, tc1, tc2) -> Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname tc1 tc2 - | Unused_value_declaration v -> "unused value " ^ v ^ "." + | Unused_value_declaration v -> + (* TODO(actions) Remove value declaration *) + "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." - | Unused_type_declaration s -> "unused type " ^ s ^ "." + | Unused_type_declaration s -> + (* TODO(actions) Remove type declaration *) + "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." - | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." + | Unused_constructor (s, false, false) -> + (* TODO(actions) Remove constructor *) + "unused constructor " ^ s ^ "." | Unused_constructor (s, true, _) -> "constructor " ^ s ^ " is never used to build values.\n\ @@ -428,7 +436,9 @@ let message = function name ^ " is never used to build values.\n\ It is exported or rebound as a private extension.") - | Unused_rec_flag -> "unused rec flag." + | Unused_rec_flag -> + (* TODO(actions) Remove rec flag *) + "unused rec flag." | Ambiguous_name ([s], tl, false) -> s ^ " belongs to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Disambiguate if this is wrong." @@ -438,10 +448,12 @@ let message = function ^ "\nThe first one was selected. Disambiguate if this is wrong." | Nonoptional_label s -> "the label " ^ s ^ " is not optional." | Open_shadow_identifier (kind, s) -> + (* TODO(actions) Force open *) Printf.sprintf "this open statement shadows the %s identifier %s (which is later used)" kind s | Open_shadow_label_constructor (kind, s) -> + (* TODO(actions) Force open *) Printf.sprintf "this open statement shadows the %s %s (which is later used)" kind s | Attribute_payload (a, s) -> @@ -483,10 +495,13 @@ let message = function "Ambiguous or-pattern variables under guard;\n\ %s may match different arguments. (See manual section 8.5)" msg - | Unused_module s -> "unused module " ^ s ^ "." + | Unused_module s -> + (* TODO(actions) Remove module *) + "unused module " ^ s ^ "." | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." | Bs_unused_attribute s -> + (* TODO(actions) Remove attribute *) "Unused attribute: @" ^ s ^ "\n\ This attribute has no effect here.\n\ @@ -505,6 +520,8 @@ let message = function "Integer literal exceeds the range of representable integers of type int" | Bs_uninterpreted_delimiters s -> "Uninterpreted delimiters " ^ s | Bs_toplevel_expression_unit help -> + (* TODO(actions) Assign to `let _ =` *) + (* TODO(actions) Ignore *) Printf.sprintf "This%sis at the top level and is expected to return `unit`. But it's \ returning %s.\n\n\ diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 28d3ee29ab4..9fc11a241e3 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2051,6 +2051,7 @@ let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss = | None -> Total | Some v -> (if Warnings.is_active (Warnings.Partial_match "") then + (* TODO(actions) Add missing cases *) let errmsg = try let buf = Buffer.create 16 in @@ -2216,6 +2217,7 @@ let check_unused pred casel = |> List.filter (fun p -> not (Variant_type_spread.is_pat_from_variant_spread_attr p)) |> List.iter (fun p -> + (* TODO(actions) Remove unused pattern *) Location.prerr_warning p.pat_loc Warnings.Unused_pat) | Used -> () with Empty | Not_found | NoGuard -> assert false); diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 7147573b8bf..cbdfc488325 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2784,6 +2784,7 @@ and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected) in let opt_exp = if List.length lid_sexp_list = num_fields then ( + (* TODO(actions) Remove `...` spread *) Location.prerr_warning loc Warnings.Useless_record_with; None) else opt_exp @@ -4720,6 +4721,7 @@ let report_error env loc ppf error = if List.length missing_required_args > 0 then ( (* TODO(actions) Add missing arguments *) + (* TODO(actions) Partially apply *) fprintf ppf "@,- Missing arguments that must be provided: %s" (missing_required_args |> List.map (fun v -> "~" ^ v) diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 3718739c4b0..858356bbce2 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -151,6 +151,7 @@ module ErrorMessages = struct `'A`" let attribute_without_node (attr : Parsetree.attribute) = + (* TODO: Be explicit about doc comments *) let {Asttypes.txt = attr_name}, _ = attr in "Did you forget to attach `" ^ attr_name ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" From 43d942220e4580f5acfc9a72f5d00898bc8c2df9 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 20:42:01 +0200 Subject: [PATCH 11/44] format --- tests/build_tests/actions/fixtures/Actions_RewriteIdent.res | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res b/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res index 5f9073f699d..bcb56f917c1 100644 --- a/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res +++ b/tests/build_tests/actions/fixtures/Actions_RewriteIdent.res @@ -1 +1 @@ -Console.log2("hello") \ No newline at end of file +Console.log2("hello") From 0dbe8ac04443584dcdaee7ed68f40705395eec10 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 21:57:31 +0200 Subject: [PATCH 12/44] more todo comments --- compiler/ml/env.ml | 12 ++++++++++-- compiler/ml/parmatch.ml | 11 +++++++++-- compiler/ml/translattribute.ml | 1 + compiler/ml/typecore.ml | 17 ++++++++++++++--- compiler/ml/typedecl.ml | 1 + compiler/ml/typetexp.ml | 4 ++++ 6 files changed, 39 insertions(+), 7 deletions(-) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index f3d04b0b608..02f7393d13a 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1638,7 +1638,9 @@ and store_type ~check id info env = let loc = info.type_loc in if check then check_usage loc id - (fun s -> Warnings.Unused_type_declaration s) + (fun s -> + (* TODO(actions) Remove unused type *) + Warnings.Unused_type_declaration s) type_declarations; let path = Pident id in let constructors = Datarepr.constructors_of_type path info in @@ -1660,6 +1662,7 @@ and store_type ~check id info env = if not (ty = "" || ty.[0] = '_') then Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then + (* TODO(actions) Remove unused constructor *) Location.prerr_warning loc (Warnings.Unused_constructor (c, used.cu_pattern, used.cu_privatize))))) @@ -1705,6 +1708,7 @@ and store_extension ~check id ext env = Hashtbl.add used_constructors k (add_constructor_usage used); Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then + (* TODO(actions) Remove unused extension *) Location.prerr_warning loc (Warnings.Unused_extension (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize))))); @@ -1718,7 +1722,11 @@ and store_extension ~check id ext env = and store_module ~check id md env = let loc = md.md_loc in if check then - check_usage loc id (fun s -> Warnings.Unused_module s) module_declarations; + check_usage loc id + (fun s -> + (* TODO(actions) Remove unused module *) + Warnings.Unused_module s) + module_declarations; let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in { diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 9fc11a241e3..a6fe7c802cd 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2028,6 +2028,7 @@ let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss = | [] -> () | _ -> if Warnings.is_active Warnings.All_clauses_guarded then + (* TODO(actions) Add catch-all clause with %todo *) Location.prerr_warning loc Warnings.All_clauses_guarded); Partial | ps :: _ -> ( @@ -2151,6 +2152,7 @@ let do_check_fragile_param exhaust loc casel pss = (fun ext -> match exhaust (Some ext) pss (List.length ps) with | Rnone -> + (* TODO(actions) Add explicit pattern for all variant constructors *) Location.prerr_warning loc (Warnings.Fragile_match (Path.name ext)) | Rsome _ -> ()) exts) @@ -2198,6 +2200,12 @@ let check_unused pred casel = let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in match pred constrs labels pattern with | None -> + Cmt_utils.add_possible_action + { + loc = q.pat_loc; + action = RemoveSwitchCase; + description = "Remove switch case"; + }; Location.prerr_warning q.pat_loc Warnings.Unreachable_case; Used | _ -> r @@ -2205,7 +2213,6 @@ let check_unused pred casel = match r with | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match; - (* TODO: Maybe move this into prerr_warning? *) Cmt_utils.add_possible_action { loc = q.pat_loc; @@ -2217,7 +2224,7 @@ let check_unused pred casel = |> List.filter (fun p -> not (Variant_type_spread.is_pat_from_variant_spread_attr p)) |> List.iter (fun p -> - (* TODO(actions) Remove unused pattern *) + (* TODO(actions) Remove unused pattern or replace with _ *) Location.prerr_warning p.pat_loc Warnings.Unused_pat) | Used -> () with Empty | Not_found | NoGuard -> assert false); diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index ed63ecbdf1e..2784f6bc46b 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -32,6 +32,7 @@ let find_attribute p (attributes : t list) = | [] -> None | [attr] -> Some attr | _ :: ({txt; loc}, _) :: _ -> + (* TODO(actions) Remove duplicate attribute *) Location.prerr_warning loc (Warnings.Duplicated_attribute txt); None in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index cbdfc488325..f416c51305f 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1404,6 +1404,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (match sargs with | [({ppat_desc = Ppat_constant _} as sp)] when Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes -> + (* TODO(actions) Use explicit pattern matching instead of literal *) Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern | _ -> ()); if List.length sargs <> constr.cstr_arity then @@ -1768,8 +1769,12 @@ let type_pattern ~lev env spat scope expected_ty = let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in let new_env, unpacks = add_pattern_variables !new_env - ~check:(fun s -> Warnings.Unused_var_strict s) - ~check_as:(fun s -> Warnings.Unused_var s) + ~check:(fun s -> + (* TODO(actions) Remove unused variable or prefix with underscore *) + Warnings.Unused_var_strict s) + ~check_as:(fun s -> + (* TODO(actions) Remove unused variable or prefix with underscore *) + Warnings.Unused_var s) in (pat, new_env, get_ref pattern_force, unpacks) @@ -2949,7 +2954,9 @@ and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected) Types.val_loc = loc; } env - ~check:(fun s -> Warnings.Unused_for_index s) + ~check:(fun s -> + (* TODO(actions) Remove unused for-loop index or prefix with underscore *) + Warnings.Unused_for_index s) | _ -> raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) in let body = type_statement ~context:None new_env sbody in @@ -3661,6 +3668,7 @@ and type_application ~context total_app env funct (sargs : sargs) : so the function type including arity can be inferred. *) let t1 = newvar () and t2 = newvar () in if ty_fun.level >= t1.level && not_identity funct.exp_desc then + (* TODO(actions) Remove unused argument or prefix with underscore *) Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; unify env ty_fun (newty @@ -3722,6 +3730,7 @@ and type_application ~context total_app env funct (sargs : sargs) : else (sargs, (l, ty, lv) :: omitted, None) | Some (l', sarg0, sargs) -> if (not optional) && is_optional l' then + (* TODO(actions) Add ? to make argument optional *) Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, @@ -4225,6 +4234,7 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s) let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in (* See PR#6677 *) Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes (fun () -> + (* TODO(actions) Remove unused rec flag *) Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag)); List.iter2 (fun pat (attrs, exp) -> @@ -4312,6 +4322,7 @@ let type_expression ~context env sexp = | Pexp_apply _ -> Some (return_type, FunctionCall) | _ -> Some (return_type, Other))) | Tags _ -> + (* TODO(actions) Assign to let _ = or pipe to ignore() *) Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); end_def (); if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index da35de5288d..a3c87608277 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1906,6 +1906,7 @@ let transl_value_decl env loc valdecl = in let id, newenv = Env.enter_value valdecl.pval_name.txt v env ~check:(fun s -> + (* TODO(actions) Remove unused value or prefix with underscore *) Warnings.Unused_value_declaration s) in let desc = diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 9867baac11a..a42e7ab5129 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -731,6 +731,7 @@ let did_you_mean ppf choices : bool = match choices () with | [] -> false | last :: rev_rest -> + (* TODO(actions) Rewrite ident *) Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" (String.concat ", " (List.rev rev_rest)) (if rev_rest = [] then "" else " or ") @@ -777,6 +778,7 @@ let report_error env ppf = function Printtyp.longident lid; let has_candidate = super_spellcheck ppf Env.fold_types env lid in if not has_candidate then + (* TODO(actions) Add rec flag *) Format.fprintf ppf "If you wanted to write a recursive type, don't forget the `rec` in \ `type rec`@]" @@ -784,6 +786,7 @@ let report_error env ppf = function fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p | Type_arity_mismatch (lid, expected, provided) -> if expected == 0 then + (* TODO(actions) Remove type parameters *) fprintf ppf "@[The type %a is not generic so expects no arguments,@ but is here \ applied to %i argument(s).@ Have you tried removing the angular \ @@ -874,6 +877,7 @@ let report_error env ppf = function match as_module with | None -> () | Some module_path -> + (* TODO(actions) Rewrite ident *) Format.fprintf ppf "@,@[@,@[%s to use the module @{%a@}?@]@]" (if did_spellcheck then "Or did you mean" else "Maybe you meant") Printtyp.path module_path) From 8985b0cb22db7b0c9677e2420397526e6aed361a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:25:26 +0200 Subject: [PATCH 13/44] refactor to centralize generating actions from warnings --- compiler/ext/warnings.ml | 3 +++ compiler/ext/warnings.mli | 2 ++ compiler/ml/cmt_utils.ml | 10 ++++++++++ compiler/ml/env.ml | 4 +--- compiler/ml/location.ml | 1 + 5 files changed, 17 insertions(+), 3 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index b792054dd72..1eb89468d75 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -707,3 +707,6 @@ let loc_to_string (loc : loc) : string = (loc.loc_start.pos_cnum - loc.loc_start.pos_bol) loc.loc_end.pos_lnum (loc.loc_end.pos_cnum - loc.loc_end.pos_bol) + +let emit_possible_actions_from_warning : (loc -> t -> unit) ref = + ref (fun _ _ -> ()) diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index ba1a03ceec5..dd79748f5cd 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -131,3 +131,5 @@ val loc_to_string : loc -> string (** Turn the location into a string with (line,column--line,column) format. *) + +val emit_possible_actions_from_warning : (loc -> t -> unit) ref diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index bfb854e254f..c1ec3cf9e91 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -46,3 +46,13 @@ type cmt_action = {loc: Location.t; action: action_type; description: string} let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action + +let emit_possible_actions_from_warning loc w = + match w with + | Warnings.Unused_open _ -> + add_possible_action {loc; action = RemoveOpen; description = "Remove open"} + | _ -> () + +let _ = + Warnings.emit_possible_actions_from_warning := + emit_possible_actions_from_warning diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 02f7393d13a..9f028675788 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1899,9 +1899,7 @@ let open_signature ?(used_slot = ref false) ?(loc = Location.none) Delayed_checks.add_delayed_check (fun () -> if not !used then ( used := true; - Location.prerr_warning loc (Warnings.Unused_open (Path.name root)); - Cmt_utils.add_possible_action - {loc; action = RemoveOpen; description = "Remove open"})); + Location.prerr_warning loc (Warnings.Unused_open (Path.name root)))); let shadowed = ref [] in let slot s b = (match check_shadowing env b with diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml index fa2e806db07..9f490f33ef5 100644 --- a/compiler/ml/location.ml +++ b/compiler/ml/location.ml @@ -153,6 +153,7 @@ let default_warning_printer loc ppf w = | `Inactive -> () | `Active {Warnings.number = _; message = _; is_error; sub_locs = _} -> setup_colors (); + !Warnings.emit_possible_actions_from_warning loc w; let message_kind = if is_error then `warning_as_error else `warning in Format.fprintf ppf "@[@, %a@, %s@,@]@." (print ~message_kind From 9ba9ce1782944f1e706f896d06970ed4caff1a7a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:28:32 +0200 Subject: [PATCH 14/44] move remaining warning driven actions to centralized place --- compiler/ml/cmt_utils.ml | 3 +++ compiler/ml/parmatch.ml | 15 +-------------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index c1ec3cf9e91..2267305146a 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -51,6 +51,9 @@ let emit_possible_actions_from_warning loc w = match w with | Warnings.Unused_open _ -> add_possible_action {loc; action = RemoveOpen; description = "Remove open"} + | Unused_match | Unreachable_case -> + add_possible_action + {loc; action = RemoveSwitchCase; description = "Remove switch case"} | _ -> () let _ = diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index a6fe7c802cd..cac8f10de1b 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2200,25 +2200,12 @@ let check_unused pred casel = let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in match pred constrs labels pattern with | None -> - Cmt_utils.add_possible_action - { - loc = q.pat_loc; - action = RemoveSwitchCase; - description = "Remove switch case"; - }; Location.prerr_warning q.pat_loc Warnings.Unreachable_case; Used | _ -> r in match r with - | Unused -> - Location.prerr_warning q.pat_loc Warnings.Unused_match; - Cmt_utils.add_possible_action - { - loc = q.pat_loc; - action = RemoveSwitchCase; - description = "Remove switch case"; - } + | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match | Upartial ps -> ps |> List.filter (fun p -> From ebfac1c4d6baad24d483e96e301eb00375dc08d7 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:51:21 +0200 Subject: [PATCH 15/44] add value_bindings to Ast_mapper --- compiler/ml/ast_mapper.ml | 6 ++++-- compiler/ml/ast_mapper.mli | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 673465477bd..27c8509f34d 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -57,6 +57,7 @@ type mapper = { type_extension: mapper -> type_extension -> type_extension; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> value_binding list -> value_binding list; value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; } @@ -247,7 +248,7 @@ module M = struct match desc with | Pstr_eval (x, attrs) -> eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_value (r, vbs) -> value ~loc r (sub.value_bindings sub vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) @@ -285,7 +286,7 @@ module E = struct | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) | Pexp_constant x -> constant ~loc ~attrs x | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + let_ ~loc ~attrs r (sub.value_bindings sub vbs) (sub.expr sub e) | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} -> fun_ ~loc ~attrs ~arity ~async lab @@ -473,6 +474,7 @@ let default_mapper = Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes)); + value_bindings = (fun this l -> List.map (this.value_binding this) l); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> Type.constructor (map_loc this pcd_name) diff --git a/compiler/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli index 745fdb8d20a..15187501e37 100644 --- a/compiler/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -85,6 +85,7 @@ type mapper = { type_extension: mapper -> type_extension -> type_extension; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> value_binding list -> value_binding list; value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; } From 3e34d2308fb1cdf93e035d6eadc35c209bbffee1 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:52:13 +0200 Subject: [PATCH 16/44] prefix unused --- compiler/ml/cmt_utils.ml | 15 +++++++++++ ...ions_PrefixUnusedVarUnderscore_applied.res | 4 +++ .../Actions_PrefixUnusedVarUnderscore.res | 4 +++ tools/src/tools.ml | 27 +++++++++++++++++++ 4 files changed, 50 insertions(+) create mode 100644 tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 2267305146a..34f329e5bb7 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -41,6 +41,8 @@ type action_type = | RewriteObjectToRecord | RewriteArrayToTuple | RewriteIdent of {new_ident: Longident.t} + | PrefixVariableWithUnderscore + | RemoveUnusedVariable type cmt_action = {loc: Location.t; action: action_type; description: string} @@ -54,6 +56,19 @@ let emit_possible_actions_from_warning loc w = | Unused_match | Unreachable_case -> add_possible_action {loc; action = RemoveSwitchCase; description = "Remove switch case"} + | Unused_var _ | Unused_var_strict _ -> + add_possible_action + { + loc; + action = PrefixVariableWithUnderscore; + description = "Prefix with `_`"; + }; + add_possible_action + { + loc; + action = RemoveUnusedVariable; + description = "Remove unused variable"; + } | _ -> () let _ = diff --git a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res new file mode 100644 index 00000000000..a023a16d76a --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res @@ -0,0 +1,4 @@ +let f = () => { + let _x = 1 + 12 +} diff --git a/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res new file mode 100644 index 00000000000..df06e64605c --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res @@ -0,0 +1,4 @@ +let f = () => { + let x = 1 + 12 +} \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 9b019254e11..30e21d7dde3 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1320,6 +1320,33 @@ module Actions = struct | _ -> Some str_item) in Ast_mapper.default_mapper.structure mapper items); + value_bindings = + (fun mapper bindings -> + (* TODO: Implement removing binding action *) + Ast_mapper.default_mapper.value_bindings mapper bindings); + pat = + (fun mapper pattern -> + let pattern = + match pattern.ppat_desc with + | Ppat_var var -> ( + let prefix_underscore_action = + actions + |> List.find_opt (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | PrefixVariableWithUnderscore -> + action.loc = pattern.ppat_loc + | _ -> false) + in + match prefix_underscore_action with + | Some _ -> + { + pattern with + ppat_desc = Ppat_var {var with txt = "_" ^ var.txt}; + } + | None -> pattern) + | _ -> pattern + in + Ast_mapper.default_mapper.pat mapper pattern); cases = (fun mapper cases -> let cases = From ce6ca42a997dceeea3d6941d45018c100515ff30 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:54:36 +0200 Subject: [PATCH 17/44] add value_bindings to Ast_iterator as well --- compiler/ml/ast_iterator.ml | 6 ++++-- compiler/ml/ast_iterator.mli | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index a430bb0b7bd..6cfe602f392 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -53,6 +53,7 @@ type iterator = { type_extension: iterator -> type_extension -> unit; type_kind: iterator -> type_kind -> unit; value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> value_binding list -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; } @@ -250,7 +251,7 @@ module M = struct | Pstr_eval (x, attrs) -> sub.expr sub x; sub.attributes sub attrs - | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_value (_r, vbs) -> sub.value_bindings sub vbs | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Pstr_typext te -> sub.type_extension sub te @@ -287,7 +288,7 @@ module E = struct | Pexp_ident x -> iter_loc sub x | Pexp_constant _ -> () | Pexp_let (_r, vbs, e) -> - List.iter (sub.value_binding sub) vbs; + sub.value_bindings sub vbs; sub.expr sub e | Pexp_fun {default = def; lhs = p; rhs = e} -> iter_opt (sub.expr sub) def; @@ -487,6 +488,7 @@ let default_iterator = this.expr this pvb_expr; this.location this pvb_loc; this.attributes this pvb_attributes); + value_bindings = (fun this l -> List.iter (this.value_binding this) l); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> iter_loc this pcd_name; diff --git a/compiler/ml/ast_iterator.mli b/compiler/ml/ast_iterator.mli index 8c7b7a5e9fe..c63aa94b6de 100644 --- a/compiler/ml/ast_iterator.mli +++ b/compiler/ml/ast_iterator.mli @@ -51,6 +51,7 @@ type iterator = { type_extension: iterator -> type_extension -> unit; type_kind: iterator -> type_kind -> unit; value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> value_binding list -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; } From 41180c3783c0e4439d8d8641f10de90c4a7bc9da Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:54:56 +0200 Subject: [PATCH 18/44] format --- .../actions/fixtures/Actions_PrefixUnusedVarUnderscore.res | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res index df06e64605c..fae6fd1b3ff 100644 --- a/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res +++ b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res @@ -1,4 +1,4 @@ let f = () => { let x = 1 12 -} \ No newline at end of file +} From fdc772e033334f80d424b8c856e81583ecd5b641 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 08:28:19 +0200 Subject: [PATCH 19/44] spellcheck --- compiler/ml/typetexp.ml | 47 ++++++++++++++----- compiler/ml/typetexp.mli | 2 +- .../Actions_SpellcheckIdent_applied.res | 2 + .../fixtures/Actions_SpellcheckIdent.res | 2 + 4 files changed, 40 insertions(+), 13 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_SpellcheckIdent.res diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index a42e7ab5129..5bcb6fd0c7d 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -41,7 +41,7 @@ type error = | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t + | Unbound_value of Longident.t * Location.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t * type_expr option | Unbound_module of Longident.t @@ -135,7 +135,9 @@ let find_all_labels = let find_value ?deprecated_context env loc lid = Env.check_value_name (Longident.last lid) loc; let ((path, decl) as r) = - find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid + find_component Env.lookup_value + (fun lid -> Unbound_value (lid, loc)) + env loc lid in Builtin_attributes.check_deprecated ?deprecated_context loc decl.val_attributes (Path.name path); @@ -722,21 +724,21 @@ let transl_type_scheme env styp = open Format open Printtyp -let did_you_mean ppf choices : bool = +let did_you_mean ppf choices : bool * string list = (* flush now to get the error report early, in the (unheard of) case where the linear search would take a bit of time; in the worst case, the user has seen the error, she can interrupt the process before the spell-checking terminates. *) Format.fprintf ppf "@?"; match choices () with - | [] -> false - | last :: rev_rest -> + | [] -> (false, []) + | last :: rev_rest as choices -> (* TODO(actions) Rewrite ident *) Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" (String.concat ", " (List.rev rev_rest)) (if rev_rest = [] then "" else " or ") last; - true + (true, choices) let super_spellcheck ppf fold env lid = let choices path name : string list = @@ -744,7 +746,7 @@ let super_spellcheck ppf fold env lid = Misc.spellcheck env name in match lid with - | Longident.Lapply _ -> false + | Longident.Lapply _ -> (false, []) | Longident.Lident s -> did_you_mean ppf (fun _ -> choices None s) | Longident.Ldot (r, s) -> did_you_mean ppf (fun _ -> choices (Some r) s) @@ -776,7 +778,7 @@ let report_error env ppf = function (* modified *) Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " Printtyp.longident lid; - let has_candidate = super_spellcheck ppf Env.fold_types env lid in + let has_candidate, _ = super_spellcheck ppf Env.fold_types env lid in if not has_candidate then (* TODO(actions) Add rec flag *) Format.fprintf ppf @@ -848,7 +850,7 @@ let report_error env ppf = function Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l Printtyp.type_expr ty Printtyp.type_expr ty') - | Unbound_value lid -> ( + | Unbound_value (lid, loc) -> ( (* modified *) (match lid with | Ldot (outer, inner) -> @@ -857,12 +859,22 @@ let report_error env ppf = function | other_ident -> Format.fprintf ppf "The value %a can't be found" Printtyp.longident other_ident); - let did_spellcheck = super_spellcheck ppf Env.fold_values env lid in + let did_spellcheck, choices = + super_spellcheck ppf Env.fold_values env lid + in + if did_spellcheck then + choices + |> List.iter (fun choice -> + Cmt_utils.add_possible_action + { + loc; + action = Cmt_utils.RewriteIdent {new_ident = Lident choice}; + description = "Change to `" ^ choice ^ "`"; + }); (* For cases such as when the user refers to something that's a value with a lowercase identifier in JS but a module in ReScript. 'Console' is a typical example, where JS is `console.log` and ReScript is `Console.log`. *) - (* TODO(codemods) Add codemod for refering to the module instead. *) let as_module = match lid with | Lident name -> ( @@ -877,7 +889,18 @@ let report_error env ppf = function match as_module with | None -> () | Some module_path -> - (* TODO(actions) Rewrite ident *) + let new_ident = + module_path |> Printtyp.string_of_path |> Longident.parse + in + Cmt_utils.add_possible_action + { + loc; + action = Cmt_utils.RewriteIdent {new_ident}; + description = + "Change to `" + ^ (new_ident |> Longident.flatten |> String.concat ".") + ^ "`"; + }; Format.fprintf ppf "@,@[@,@[%s to use the module @{%a@}?@]@]" (if did_spellcheck then "Or did you mean" else "Maybe you meant") Printtyp.path module_path) diff --git a/compiler/ml/typetexp.mli b/compiler/ml/typetexp.mli index 8f40096392f..ce814c2fb9c 100644 --- a/compiler/ml/typetexp.mli +++ b/compiler/ml/typetexp.mli @@ -50,7 +50,7 @@ type error = | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t + | Unbound_value of Longident.t * Location.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t * type_expr option | Unbound_module of Longident.t diff --git a/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res b/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res new file mode 100644 index 00000000000..060aceca5a2 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res @@ -0,0 +1,2 @@ +let aaaaa = 10 +let b = aaaaa diff --git a/tests/build_tests/actions/fixtures/Actions_SpellcheckIdent.res b/tests/build_tests/actions/fixtures/Actions_SpellcheckIdent.res new file mode 100644 index 00000000000..dc6051081df --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_SpellcheckIdent.res @@ -0,0 +1,2 @@ +let aaaaa = 10 +let b = aaaab From dcf06ea5ff3b4a32e3e44af0329a1fcbf6aa2c44 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:02:30 +0200 Subject: [PATCH 20/44] allow filtering actions, and add test for removing unused var entirely --- ...ions_PrefixUnusedVarUnderscore_applied.res | 1 + .../Actions_RemoveUnusedVar_applied.res | 4 ++ .../Actions_PrefixUnusedVarUnderscore.res | 1 + .../fixtures/Actions_RemoveUnusedVar.res | 5 ++ tests/build_tests/actions/input.js | 13 ++-- tools/bin/main.ml | 15 ++++- tools/src/tools.ml | 64 +++++++++++++++++-- 7 files changed, 92 insertions(+), 11 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveUnusedVar.res diff --git a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res index a023a16d76a..ee3ddd6e275 100644 --- a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res +++ b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res @@ -1,3 +1,4 @@ +// actionFilter=PrefixVariableWithUnderscore let f = () => { let _x = 1 12 diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res new file mode 100644 index 00000000000..827b646e0ac --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res @@ -0,0 +1,4 @@ +// actionFilter=RemoveUnusedVariable +let f = () => { + 12 +} diff --git a/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res index fae6fd1b3ff..ce8db0b896f 100644 --- a/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res +++ b/tests/build_tests/actions/fixtures/Actions_PrefixUnusedVarUnderscore.res @@ -1,3 +1,4 @@ +// actionFilter=PrefixVariableWithUnderscore let f = () => { let x = 1 12 diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveUnusedVar.res b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedVar.res new file mode 100644 index 00000000000..080861e1f6e --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedVar.res @@ -0,0 +1,5 @@ +// actionFilter=RemoveUnusedVariable +let f = () => { + let x = 1 + 12 +} diff --git a/tests/build_tests/actions/input.js b/tests/build_tests/actions/input.js index 3b7cb68ded5..51d7e47e6f5 100644 --- a/tests/build_tests/actions/input.js +++ b/tests/build_tests/actions/input.js @@ -35,11 +35,14 @@ for (const fileName of fixtures) { const fullFilePath = path.join(import.meta.dirname, "fixtures", fileName); const cmtPath = fullFilePath.replace(".res", ".cmt"); await bsc([...prefix, "-color", "always", fullFilePath]); - const { stdout, stderr } = await rescriptTools("actions", [ - fullFilePath, - cmtPath, - "--runAll", - ]); + const firstLine = + (await fs.readFile(fullFilePath, "utf-8")).split("\n")[0] ?? ""; + const actionFilter = firstLine.split("actionFilter=")[1]; + const callArgs = [fullFilePath, cmtPath, "--runAll"]; + if (actionFilter != null) { + callArgs.push("--actionFilter", actionFilter); + } + const { stdout, stderr } = await rescriptTools("actions", callArgs); if (stderr.length > 0) { console.error(stderr.toString()); } diff --git a/tools/bin/main.ml b/tools/bin/main.ml index ae3759e2e04..32c151314f2 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -179,12 +179,25 @@ let main () = Reanalyze.cli () | "actions" :: file :: opts -> let run_all_on_file = List.mem "--runAll" opts in + let rec extract_arg_with_value target_arg opts = + match opts with + | arg :: value :: _ when arg = target_arg -> Some value + | _ :: rest -> extract_arg_with_value target_arg rest + | [] -> None + in let cmtPath = match opts with | path :: _ when String.ends_with ~suffix:".cmt" path -> Some path | _ -> None in - if run_all_on_file then Tools.Actions.runActionsOnFile ?cmtPath file + let actionFilter = + match extract_arg_with_value "--actionFilter" opts with + | Some filter -> + Some (String.split_on_char ',' filter |> List.map String.trim) + | None -> None + in + if run_all_on_file then + Tools.Actions.runActionsOnFile ?actionFilter ?cmtPath file else Tools.Actions.extractActionsFromFile ?cmtPath file | "extract-embedded" :: extPointNames :: filename :: _ -> logAndExit diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 30e21d7dde3..9fda7d5c016 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1322,7 +1322,23 @@ module Actions = struct Ast_mapper.default_mapper.structure mapper items); value_bindings = (fun mapper bindings -> - (* TODO: Implement removing binding action *) + let remove_unused_variables_action_locs = + List.filter_map + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveUnusedVariable -> Some action.loc + | _ -> None) + actions + in + let bindings = + bindings + |> List.filter_map (fun (binding : Parsetree.value_binding) -> + if + List.mem binding.pvb_pat.ppat_loc + remove_unused_variables_action_locs + then None + else Some binding) + in Ast_mapper.default_mapper.value_bindings mapper bindings); pat = (fun mapper pattern -> @@ -1493,9 +1509,20 @@ module Actions = struct } | _ -> None) in + let mapped_expr = + match mapped_expr with + | None -> Ast_mapper.default_mapper.expr mapper expr + | Some expr -> expr + in + (* We sometimes need to do some post-transformation cleanup. + E.g if all let bindings was removed from `Pexp_let`, we need to remove the entire Pexp_let.*) match mapped_expr with - | None -> Ast_mapper.default_mapper.expr mapper expr - | Some expr -> expr); + | {pexp_desc = Pexp_let (_, [], cont); pexp_attributes} -> + { + cont with + pexp_attributes = cont.pexp_attributes @ pexp_attributes; + } + | _ -> mapped_expr); } in if Filename.check_suffix path ".res" then @@ -1512,7 +1539,8 @@ module Actions = struct "error: failed to apply actions to %s because it is not a .res file" path) - let runActionsOnFile ?cmtPath entryPointFile = + let runActionsOnFile ?(actionFilter : string list option) ?cmtPath + entryPointFile = let path = match Filename.is_relative entryPointFile with | true -> Unix.realpath entryPointFile @@ -1530,7 +1558,33 @@ module Actions = struct be found. try to build the project" path | Some {cmt_possible_actions} -> ( - match applyActionsToFile path cmt_possible_actions with + let possible_actions = + match actionFilter with + | None -> cmt_possible_actions + | Some filter -> + cmt_possible_actions + |> List.filter (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | Cmt_utils.ApplyFunction _ -> List.mem "ApplyFunction" filter + | ApplyCoercion _ -> List.mem "ApplyCoercion" filter + | RemoveSwitchCase -> List.mem "RemoveSwitchCase" filter + | RemoveOpen -> List.mem "RemoveOpen" filter + | RemoveAwait -> List.mem "RemoveAwait" filter + | AddAwait -> List.mem "AddAwait" filter + | ReplaceWithVariantConstructor _ -> + List.mem "ReplaceWithVariantConstructor" filter + | ReplaceWithPolymorphicVariantConstructor _ -> + List.mem "ReplaceWithPolymorphicVariantConstructor" filter + | RewriteObjectToRecord -> + List.mem "RewriteObjectToRecord" filter + | RewriteArrayToTuple -> List.mem "RewriteArrayToTuple" filter + | RewriteIdent _ -> List.mem "RewriteIdent" filter + | PrefixVariableWithUnderscore -> + List.mem "PrefixVariableWithUnderscore" filter + | RemoveUnusedVariable -> + List.mem "RemoveUnusedVariable" filter) + in + match applyActionsToFile path possible_actions with | Ok applied -> print_endline applied | Error e -> print_endline e; From 8730f9586011f4e70335759fc3b2e5487af73571 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:39:03 +0200 Subject: [PATCH 21/44] emit all available actions in a comment in applied file --- compiler/ml/cmt_utils.ml | 25 +++++++++++++++++++ .../expected/Actions_AddAwait_applied.res | 4 +++ .../Actions_ApplyCoercion_applied.res | 4 +++ ...ctions_ApplyConversionFunction_applied.res | 4 +++ ...tions_IdentButDidYouMeanModule_applied.res | 5 ++++ ...ons_JSXCustomComponentChildren_applied.res | 4 +++ ...ions_PrefixUnusedVarUnderscore_applied.res | 4 +++ .../expected/Actions_RemoveAwait_applied.res | 4 +++ .../Actions_RemoveUnusedVar_applied.res | 4 +++ .../Actions_RewriteArrayToTuple2_applied.res | 4 +++ .../Actions_RewriteArrayToTuple_applied.res | 5 ++++ .../expected/Actions_RewriteIdent_applied.res | 4 +++ .../Actions_RewriteObjectToRecord_applied.res | 4 +++ .../Actions_SpellcheckIdent_applied.res | 4 +++ ...nstantToPolyvariantConstructor_applied.res | 4 +++ ...ngConstantToVariantConstructor_applied.res | 4 +++ .../expected/Actions_UnusedOpen_applied.res | 4 +++ .../Actions_UnusedSwitchCase_applied.res | 4 +++ .../Actions_IdentButDidYouMeanModule.res | 1 + tools/src/tools.ml | 10 +++++++- 20 files changed, 105 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_IdentButDidYouMeanModule.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 34f329e5bb7..db24466f830 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -46,6 +46,31 @@ type action_type = type cmt_action = {loc: Location.t; action: action_type; description: string} +let action_to_string = function + | ApplyFunction {function_name} -> + Printf.sprintf "ApplyFunction(%s)" + (Longident.flatten function_name |> String.concat ".") + | ApplyCoercion {coerce_to_name} -> + Printf.sprintf "ApplyCoercion(%s)" + (Longident.flatten coerce_to_name |> String.concat ".") + | RemoveSwitchCase -> "RemoveSwitchCase" + | RemoveOpen -> "RemoveOpen" + | RemoveAwait -> "RemoveAwait" + | AddAwait -> "AddAwait" + | RewriteObjectToRecord -> "RewriteObjectToRecord" + | RewriteArrayToTuple -> "RewriteArrayToTuple" + | PrefixVariableWithUnderscore -> "PrefixVariableWithUnderscore" + | RemoveUnusedVariable -> "RemoveUnusedVariable" + | ReplaceWithVariantConstructor {constructor_name} -> + Printf.sprintf "ReplaceWithVariantConstructor(%s)" + (constructor_name |> Longident.flatten |> String.concat ".") + | ReplaceWithPolymorphicVariantConstructor {constructor_name} -> + Printf.sprintf "ReplaceWithPolymorphicVariantConstructor(%s)" + constructor_name + | RewriteIdent {new_ident} -> + Printf.sprintf "RewriteIdent(%s)" + (Longident.flatten new_ident |> String.concat ".") + let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action diff --git a/tests/build_tests/actions/expected/Actions_AddAwait_applied.res b/tests/build_tests/actions/expected/Actions_AddAwait_applied.res index 3aab13b1c0e..a651c5e6595 100644 --- a/tests/build_tests/actions/expected/Actions_AddAwait_applied.res +++ b/tests/build_tests/actions/expected/Actions_AddAwait_applied.res @@ -3,3 +3,7 @@ let fn = async () => 12 let other = async (): int => { await fn() } + +/* === AVAILABLE ACTIONS: +- AddAwait - Await promise +*/ diff --git a/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res index 0d3e13f2d09..2294ba4390b 100644 --- a/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res +++ b/tests/build_tests/actions/expected/Actions_ApplyCoercion_applied.res @@ -3,3 +3,7 @@ type x2 = | ...x1 | Two let x1: x1 = One let x2: x2 = (x1 :> x2) + +/* === AVAILABLE ACTIONS: +- ApplyCoercion(x2) - Coerce to x2 +*/ diff --git a/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res index c197469c741..b72e89cc8d3 100644 --- a/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res +++ b/tests/build_tests/actions/expected/Actions_ApplyConversionFunction_applied.res @@ -1 +1,5 @@ let x: int = Float.toInt(12.) + +/* === AVAILABLE ACTIONS: +- ApplyFunction(Float.toInt) - Convert to int with Float.toInt +*/ diff --git a/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res b/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res new file mode 100644 index 00000000000..bcfb045c575 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res @@ -0,0 +1,5 @@ +\"Console".log(123) + +/* === AVAILABLE ACTIONS: +- RewriteIdent(Console) - Change to `Console` +*/ diff --git a/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res b/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res index 7e2793ec416..d9261ca3f3d 100644 --- a/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res +++ b/tests/build_tests/actions/expected/Actions_JSXCustomComponentChildren_applied.res @@ -22,3 +22,7 @@ module CustomComponent = { } let x = {React.float(1.)} + +/* === AVAILABLE ACTIONS: +- ApplyFunction(React.float) - Convert to float with React.float +*/ diff --git a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res index ee3ddd6e275..0214add773f 100644 --- a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res +++ b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res @@ -3,3 +3,7 @@ let f = () => { let _x = 1 12 } + +/* === AVAILABLE ACTIONS: +- PrefixVariableWithUnderscore - Prefix with `_` +*/ diff --git a/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res b/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res index caf49c133c8..6071c2d522e 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveAwait_applied.res @@ -1,2 +1,6 @@ let f = 12 let x = f + +/* === AVAILABLE ACTIONS: +- RemoveAwait - Remove await +*/ diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res index 827b646e0ac..49ff8b31610 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res @@ -2,3 +2,7 @@ let f = () => { 12 } + +/* === AVAILABLE ACTIONS: +- RemoveUnusedVariable - Remove unused variable +*/ diff --git a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res index 041f6910bbb..eb04e4e08ea 100644 --- a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res +++ b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple2_applied.res @@ -3,3 +3,7 @@ let doStuff = ((one, two)) => { } let x = doStuff(("hello", "world")) + +/* === AVAILABLE ACTIONS: +- RewriteArrayToTuple - Rewrite to tuple +*/ diff --git a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res index 29fe44ad724..4af04fc8f79 100644 --- a/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res +++ b/tests/build_tests/actions/expected/Actions_RewriteArrayToTuple_applied.res @@ -1 +1,6 @@ let x = (1, 2, "hello") + +/* === AVAILABLE ACTIONS: +- ApplyFunction(Int.fromString) - Convert to int with Int.fromString +- RewriteArrayToTuple - Rewrite to tuple +*/ diff --git a/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res b/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res index 5fbfedf4167..f44fc78b2a7 100644 --- a/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res +++ b/tests/build_tests/actions/expected/Actions_RewriteIdent_applied.res @@ -1 +1,5 @@ Console.log("hello") + +/* === AVAILABLE ACTIONS: +- RewriteIdent(Console.log) - Rewrite to use Console.log +*/ diff --git a/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res b/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res index 3f7d7b2c63f..f448225c03a 100644 --- a/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res +++ b/tests/build_tests/actions/expected/Actions_RewriteObjectToRecord_applied.res @@ -2,3 +2,7 @@ type x = {one: bool} type xx = array let x: xx = [{one: true}] + +/* === AVAILABLE ACTIONS: +- RewriteObjectToRecord - Rewrite object to record +*/ diff --git a/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res b/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res index 060aceca5a2..6a0af8a6fac 100644 --- a/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res +++ b/tests/build_tests/actions/expected/Actions_SpellcheckIdent_applied.res @@ -1,2 +1,6 @@ let aaaaa = 10 let b = aaaaa + +/* === AVAILABLE ACTIONS: +- RewriteIdent(aaaaa) - Change to `aaaaa` +*/ diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res index 8e5c1faaf03..8032bbd5627 100644 --- a/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res +++ b/tests/build_tests/actions/expected/Actions_StringConstantToPolyvariantConstructor_applied.res @@ -6,3 +6,7 @@ let doStuff = (a: int, b: [#ONE | #TWO]) => { } let x = doStuff(1, #ONE) + +/* === AVAILABLE ACTIONS: +- ReplaceWithPolymorphicVariantConstructor(ONE) - Replace with polymorphic variant constructor ONE +*/ diff --git a/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res index 9bde3d17d57..00e0fba7b17 100644 --- a/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res +++ b/tests/build_tests/actions/expected/Actions_StringConstantToVariantConstructor_applied.res @@ -9,3 +9,7 @@ let processStatus = (s: status) => { } let result = processStatus(Active) + +/* === AVAILABLE ACTIONS: +- ReplaceWithVariantConstructor(Active) - Replace with variant constructor Active +*/ diff --git a/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res index f5e64001137..57c8bd6a081 100644 --- a/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res +++ b/tests/build_tests/actions/expected/Actions_UnusedOpen_applied.res @@ -1,3 +1,7 @@ module X = { let doStuff = s => Console.log(s) } + +/* === AVAILABLE ACTIONS: +- RemoveOpen - Remove open +*/ diff --git a/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res index 9ff0ec466fc..d51669487b9 100644 --- a/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res +++ b/tests/build_tests/actions/expected/Actions_UnusedSwitchCase_applied.res @@ -3,3 +3,7 @@ let x1 = switch Some(true) { | Some(false) => 2 | None => 3 } + +/* === AVAILABLE ACTIONS: +- RemoveSwitchCase - Remove switch case +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_IdentButDidYouMeanModule.res b/tests/build_tests/actions/fixtures/Actions_IdentButDidYouMeanModule.res new file mode 100644 index 00000000000..cbf92a5557b --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_IdentButDidYouMeanModule.res @@ -0,0 +1 @@ +console.log(123) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 9fda7d5c016..c9ac9f25aa1 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1585,7 +1585,15 @@ module Actions = struct List.mem "RemoveUnusedVariable" filter) in match applyActionsToFile path possible_actions with - | Ok applied -> print_endline applied + | Ok applied -> + print_endline applied; + print_endline "/* === AVAILABLE ACTIONS:"; + possible_actions + |> List.iter (fun (action : Cmt_utils.cmt_action) -> + Printf.printf "- %s - %s\n" + (Cmt_utils.action_to_string action.action) + action.description); + print_endline "*/" | Error e -> print_endline e; exit 1) From 9371d826fac7ec431b64192af90514780904fdff Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:50:33 +0200 Subject: [PATCH 22/44] fix ident-to-module action --- compiler/ml/cmt_utils.ml | 3 ++ compiler/ml/typetexp.ml | 29 +++++++++---------- ...tions_IdentButDidYouMeanModule_applied.res | 4 +-- tools/src/tools.ml | 18 ++++++++++++ 4 files changed, 37 insertions(+), 17 deletions(-) diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index db24466f830..b0e80b5100c 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -40,6 +40,7 @@ type action_type = | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} | RewriteObjectToRecord | RewriteArrayToTuple + | RewriteIdentToModule of {module_name: string} | RewriteIdent of {new_ident: Longident.t} | PrefixVariableWithUnderscore | RemoveUnusedVariable @@ -59,6 +60,8 @@ let action_to_string = function | AddAwait -> "AddAwait" | RewriteObjectToRecord -> "RewriteObjectToRecord" | RewriteArrayToTuple -> "RewriteArrayToTuple" + | RewriteIdentToModule {module_name} -> + Printf.sprintf "RewriteIdentToModule(%s)" module_name | PrefixVariableWithUnderscore -> "PrefixVariableWithUnderscore" | RemoveUnusedVariable -> "RemoveUnusedVariable" | ReplaceWithVariantConstructor {constructor_name} -> diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 5bcb6fd0c7d..3e3cb2f9570 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -875,35 +875,34 @@ let report_error env ppf = function a lowercase identifier in JS but a module in ReScript. 'Console' is a typical example, where JS is `console.log` and ReScript is `Console.log`. *) - let as_module = + let as_module_name = match lid with - | Lident name -> ( + | Lident name -> Some (String.capitalize_ascii name) + | _ -> None + in + let as_module = + match as_module_name with + | Some name -> ( try Some (env |> Env.lookup_module ~load:false (Lident (String.capitalize_ascii name))) with _ -> None) - | _ -> None + | None -> None in - match as_module with - | None -> () - | Some module_path -> - let new_ident = - module_path |> Printtyp.string_of_path |> Longident.parse - in + match (as_module, as_module_name) with + | Some module_path, Some as_module_name -> Cmt_utils.add_possible_action { loc; - action = Cmt_utils.RewriteIdent {new_ident}; - description = - "Change to `" - ^ (new_ident |> Longident.flatten |> String.concat ".") - ^ "`"; + action = Cmt_utils.RewriteIdentToModule {module_name = as_module_name}; + description = "Change to `" ^ as_module_name ^ "`"; }; Format.fprintf ppf "@,@[@,@[%s to use the module @{%a@}?@]@]" (if did_spellcheck then "Or did you mean" else "Maybe you meant") - Printtyp.path module_path) + Printtyp.path module_path + | _ -> ()) | Unbound_module lid -> (* modified *) (match lid with diff --git a/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res b/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res index bcfb045c575..a0180da07f1 100644 --- a/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res +++ b/tests/build_tests/actions/expected/Actions_IdentButDidYouMeanModule_applied.res @@ -1,5 +1,5 @@ -\"Console".log(123) +Console.log(123) /* === AVAILABLE ACTIONS: -- RewriteIdent(Console) - Change to `Console` +- RewriteIdentToModule(Console) - Change to `Console` */ diff --git a/tools/src/tools.ml b/tools/src/tools.ml index c9ac9f25aa1..487a75a410c 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1487,6 +1487,22 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | ( Pexp_field + ( {pexp_desc = Pexp_ident e}, + {txt = Lident inner; loc} ), + RewriteIdentToModule {module_name} ) + when e.loc = action.loc -> + Some + { + expr with + pexp_desc = + Pexp_ident + { + loc; + txt = + Longident.Ldot (Lident module_name, inner); + }; + } | Pexp_await inner, RemoveAwait when inner.pexp_loc = action.loc -> Some (Ast_mapper.default_mapper.expr mapper inner) @@ -1579,6 +1595,8 @@ module Actions = struct List.mem "RewriteObjectToRecord" filter | RewriteArrayToTuple -> List.mem "RewriteArrayToTuple" filter | RewriteIdent _ -> List.mem "RewriteIdent" filter + | RewriteIdentToModule _ -> + List.mem "RewriteIdentToModule" filter | PrefixVariableWithUnderscore -> List.mem "PrefixVariableWithUnderscore" filter | RemoveUnusedVariable -> From f953135673ed536e6f608aed3eecefb1b13f8b04 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 10:11:32 +0200 Subject: [PATCH 23/44] unused value declarations --- compiler/ext/warnings.ml | 6 +----- compiler/ml/cmt_utils.ml | 5 ++++- compiler/ml/typedecl.ml | 1 - .../expected/Actions_RemoveUnusedValue_applied.res | 6 ++++++ .../actions/fixtures/Actions_RemoveUnusedValue.res | 4 ++++ tools/src/tools.ml | 9 ++++++++- 6 files changed, 23 insertions(+), 8 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveUnusedValue.res diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 1eb89468d75..30964c59ae1 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -388,8 +388,6 @@ let message = function "this pattern-matching is not exhaustive.\n\ All clauses in this pattern-matching are guarded." | Unused_var v | Unused_var_strict v -> - (* TODO(actions) Prefix with `_` *) - (* TODO(actions) Remove variable *) Format.sprintf "unused variable %s.\n\n\ Fix this by:\n\ @@ -405,9 +403,7 @@ let message = function | Duplicate_definitions (kind, cname, tc1, tc2) -> Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname tc1 tc2 - | Unused_value_declaration v -> - (* TODO(actions) Remove value declaration *) - "unused value " ^ v ^ "." + | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> (* TODO(actions) Remove type declaration *) diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index b0e80b5100c..b937506a7c6 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -45,6 +45,9 @@ type action_type = | PrefixVariableWithUnderscore | RemoveUnusedVariable +(* TODO: +- Unused var in patterns (and aliases )*) + type cmt_action = {loc: Location.t; action: action_type; description: string} let action_to_string = function @@ -84,7 +87,7 @@ let emit_possible_actions_from_warning loc w = | Unused_match | Unreachable_case -> add_possible_action {loc; action = RemoveSwitchCase; description = "Remove switch case"} - | Unused_var _ | Unused_var_strict _ -> + | Unused_var _ | Unused_var_strict _ | Unused_value_declaration _ -> add_possible_action { loc; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index a3c87608277..da35de5288d 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1906,7 +1906,6 @@ let transl_value_decl env loc valdecl = in let id, newenv = Env.enter_value valdecl.pval_name.txt v env ~check:(fun s -> - (* TODO(actions) Remove unused value or prefix with underscore *) Warnings.Unused_value_declaration s) in let desc = diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res new file mode 100644 index 00000000000..44fc18dd3e0 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res @@ -0,0 +1,6 @@ +// actionFilter=RemoveUnusedVariable +module M: {} = {} + +/* === AVAILABLE ACTIONS: +- RemoveUnusedVariable - Remove unused variable +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveUnusedValue.res b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedValue.res new file mode 100644 index 00000000000..6c1d0f536f1 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedValue.res @@ -0,0 +1,4 @@ +// actionFilter=RemoveUnusedVariable +module M: {} = { + let x = 12 +} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 487a75a410c..8f8ebd67f97 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1319,7 +1319,14 @@ module Actions = struct | None -> Some str_item) | _ -> Some str_item) in - Ast_mapper.default_mapper.structure mapper items); + let items = Ast_mapper.default_mapper.structure mapper items in + + (* Cleanup if needed *) + items + |> List.filter_map (fun (str_item : Parsetree.structure_item) -> + match str_item.pstr_desc with + | Pstr_value (_, []) -> None + | _ -> Some str_item)); value_bindings = (fun mapper bindings -> let remove_unused_variables_action_locs = From 0d5f9c1e3aaabf6b6a7ba5f24c2c3283e0303dbc Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 10:32:00 +0200 Subject: [PATCH 24/44] remove unused modules and types --- compiler/ml/cmt_utils.ml | 14 +++++++++ compiler/ml/env.ml | 10 ++----- compiler/ml/parmatch.ml | 1 - compiler/ml/typecore.ml | 10 ++----- .../Actions_RemoveUnusedModule_applied.res | 6 ++++ .../Actions_RemoveUnusedType_applied.res | 6 ++++ .../fixtures/Actions_RemoveUnusedModule.res | 6 ++++ .../fixtures/Actions_RemoveUnusedType.res | 4 +++ tools/src/tools.ml | 29 ++++++++++++++++++- 9 files changed, 68 insertions(+), 18 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_RemoveUnusedType_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveUnusedModule.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveUnusedType.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index b937506a7c6..e07c20ced12 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -44,6 +44,8 @@ type action_type = | RewriteIdent of {new_ident: Longident.t} | PrefixVariableWithUnderscore | RemoveUnusedVariable + | RemoveUnusedType + | RemoveUnusedModule (* TODO: - Unused var in patterns (and aliases )*) @@ -67,6 +69,8 @@ let action_to_string = function Printf.sprintf "RewriteIdentToModule(%s)" module_name | PrefixVariableWithUnderscore -> "PrefixVariableWithUnderscore" | RemoveUnusedVariable -> "RemoveUnusedVariable" + | RemoveUnusedType -> "RemoveUnusedType" + | RemoveUnusedModule -> "RemoveUnusedModule" | ReplaceWithVariantConstructor {constructor_name} -> Printf.sprintf "ReplaceWithVariantConstructor(%s)" (constructor_name |> Longident.flatten |> String.concat ".") @@ -100,6 +104,16 @@ let emit_possible_actions_from_warning loc w = action = RemoveUnusedVariable; description = "Remove unused variable"; } + | Unused_type_declaration _ -> + add_possible_action + {loc; action = RemoveUnusedType; description = "Remove unused type"} + | Unused_module _ -> + add_possible_action + {loc; action = RemoveUnusedModule; description = "Remove unused module"} + | Unused_pat -> (* TODO: Remove full pattern. *) () + | Unused_argument -> + (* TODO(actions) Remove unused argument or prefix with underscore *) () + | Unused_rec_flag -> (* TODO(actions) Remove unused rec flag *) () | _ -> () let _ = diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 9f028675788..5cd43e31791 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1638,9 +1638,7 @@ and store_type ~check id info env = let loc = info.type_loc in if check then check_usage loc id - (fun s -> - (* TODO(actions) Remove unused type *) - Warnings.Unused_type_declaration s) + (fun s -> Warnings.Unused_type_declaration s) type_declarations; let path = Pident id in let constructors = Datarepr.constructors_of_type path info in @@ -1722,11 +1720,7 @@ and store_extension ~check id ext env = and store_module ~check id md env = let loc = md.md_loc in if check then - check_usage loc id - (fun s -> - (* TODO(actions) Remove unused module *) - Warnings.Unused_module s) - module_declarations; + check_usage loc id (fun s -> Warnings.Unused_module s) module_declarations; let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in { diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index cac8f10de1b..6e2b7f2b2b1 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2211,7 +2211,6 @@ let check_unused pred casel = |> List.filter (fun p -> not (Variant_type_spread.is_pat_from_variant_spread_attr p)) |> List.iter (fun p -> - (* TODO(actions) Remove unused pattern or replace with _ *) Location.prerr_warning p.pat_loc Warnings.Unused_pat) | Used -> () with Empty | Not_found | NoGuard -> assert false); diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index f416c51305f..448568d5298 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1769,12 +1769,8 @@ let type_pattern ~lev env spat scope expected_ty = let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in let new_env, unpacks = add_pattern_variables !new_env - ~check:(fun s -> - (* TODO(actions) Remove unused variable or prefix with underscore *) - Warnings.Unused_var_strict s) - ~check_as:(fun s -> - (* TODO(actions) Remove unused variable or prefix with underscore *) - Warnings.Unused_var s) + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) in (pat, new_env, get_ref pattern_force, unpacks) @@ -3668,7 +3664,6 @@ and type_application ~context total_app env funct (sargs : sargs) : so the function type including arity can be inferred. *) let t1 = newvar () and t2 = newvar () in if ty_fun.level >= t1.level && not_identity funct.exp_desc then - (* TODO(actions) Remove unused argument or prefix with underscore *) Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; unify env ty_fun (newty @@ -4234,7 +4229,6 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s) let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in (* See PR#6677 *) Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes (fun () -> - (* TODO(actions) Remove unused rec flag *) Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag)); List.iter2 (fun pat (attrs, exp) -> diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res new file mode 100644 index 00000000000..16b1575b07b --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res @@ -0,0 +1,6 @@ +// actionFilter=RemoveUnusedModule +module M: {} = {} + +/* === AVAILABLE ACTIONS: +- RemoveUnusedModule - Remove unused module +*/ diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedType_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedType_applied.res new file mode 100644 index 00000000000..fea4ca49d74 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedType_applied.res @@ -0,0 +1,6 @@ +// actionFilter=RemoveUnusedType +module M: {} = {} + +/* === AVAILABLE ACTIONS: +- RemoveUnusedType - Remove unused type +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveUnusedModule.res b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedModule.res new file mode 100644 index 00000000000..3400742ca3d --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedModule.res @@ -0,0 +1,6 @@ +// actionFilter=RemoveUnusedModule +module M: {} = { + module N = { + let x = 12 + } +} diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveUnusedType.res b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedType.res new file mode 100644 index 00000000000..813bd607e03 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveUnusedType.res @@ -0,0 +1,4 @@ +// actionFilter=RemoveUnusedType +module M: {} = { + type t = int +} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 8f8ebd67f97..a2d5137a4ce 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1317,6 +1317,31 @@ module Actions = struct match remove_open_action with | Some _ -> None | None -> Some str_item) + | Pstr_type (_, _type_declarations) -> ( + let remove_unused_type_action = + actions + |> List.find_opt + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveUnusedType -> + action.loc = str_item.pstr_loc + | _ -> false) + in + match remove_unused_type_action with + | Some _ -> None + | None -> Some str_item) + | Pstr_module {pmb_loc} -> + let remove_unused_module_action_locs = + List.filter_map + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveUnusedModule -> Some action.loc + | _ -> None) + actions + in + if List.mem pmb_loc remove_unused_module_action_locs then + None + else Some str_item | _ -> Some str_item) in let items = Ast_mapper.default_mapper.structure mapper items in @@ -1607,7 +1632,9 @@ module Actions = struct | PrefixVariableWithUnderscore -> List.mem "PrefixVariableWithUnderscore" filter | RemoveUnusedVariable -> - List.mem "RemoveUnusedVariable" filter) + List.mem "RemoveUnusedVariable" filter + | RemoveUnusedType -> List.mem "RemoveUnusedType" filter + | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 8a6fdc90cb51f9f5dffd3015f7474cf2647d15e5 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 11:48:37 +0200 Subject: [PATCH 25/44] remove unused rec flag --- compiler/ext/warnings.ml | 8 ++--- compiler/ml/cmt_utils.ml | 6 +++- .../Actions_RemoveRecFlag_applied.res | 10 ++++++ .../fixtures/Actions_RemoveRecFlag.res | 5 +++ tools/src/tools.ml | 32 ++++++++++++++++++- 5 files changed, 53 insertions(+), 8 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 30964c59ae1..6a899bd7f55 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -405,9 +405,7 @@ let message = function tc1 tc2 | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." - | Unused_type_declaration s -> - (* TODO(actions) Remove type declaration *) - "unused type " ^ s ^ "." + | Unused_type_declaration s -> "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." | Unused_constructor (s, false, false) -> (* TODO(actions) Remove constructor *) @@ -432,9 +430,7 @@ let message = function name ^ " is never used to build values.\n\ It is exported or rebound as a private extension.") - | Unused_rec_flag -> - (* TODO(actions) Remove rec flag *) - "unused rec flag." + | Unused_rec_flag -> "unused rec flag." | Ambiguous_name ([s], tl, false) -> s ^ " belongs to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Disambiguate if this is wrong." diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index e07c20ced12..c901521ee2a 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -46,6 +46,7 @@ type action_type = | RemoveUnusedVariable | RemoveUnusedType | RemoveUnusedModule + | RemoveRecFlag (* TODO: - Unused var in patterns (and aliases )*) @@ -80,6 +81,7 @@ let action_to_string = function | RewriteIdent {new_ident} -> Printf.sprintf "RewriteIdent(%s)" (Longident.flatten new_ident |> String.concat ".") + | RemoveRecFlag -> "RemoveRecFlag" let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action @@ -113,7 +115,9 @@ let emit_possible_actions_from_warning loc w = | Unused_pat -> (* TODO: Remove full pattern. *) () | Unused_argument -> (* TODO(actions) Remove unused argument or prefix with underscore *) () - | Unused_rec_flag -> (* TODO(actions) Remove unused rec flag *) () + | Unused_rec_flag -> + add_possible_action + {loc; action = RemoveRecFlag; description = "Remove rec flag"} | _ -> () let _ = diff --git a/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res b/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res new file mode 100644 index 00000000000..9ba4ea151bc --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res @@ -0,0 +1,10 @@ +// actionFilter=RemoveRecFlag +let f = 12 +let fn = () => { + let x = 12 +} + +/* === AVAILABLE ACTIONS: +- RemoveRecFlag - Remove rec flag +- RemoveRecFlag - Remove rec flag +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res b/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res new file mode 100644 index 00000000000..7c3ee1d2ccd --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res @@ -0,0 +1,5 @@ +// actionFilter=RemoveRecFlag +let rec f = 12 +let fn = () => { + let rec x = 12 +} \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index a2d5137a4ce..2f62de0b215 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1299,6 +1299,24 @@ module Actions = struct let mapper = { Ast_mapper.default_mapper with + structure_item = + (fun mapper str_item -> + let remove_rec_flag_action_locs = + List.filter_map + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | RemoveRecFlag -> Some action.loc + | _ -> None) + actions + in + match str_item.pstr_desc with + | Pstr_value (Recursive, ({pvb_pat = {ppat_loc}} :: _ as bindings)) + when List.mem ppat_loc remove_rec_flag_action_locs -> + let str_item = + Ast_mapper.default_mapper.structure_item mapper str_item + in + {str_item with pstr_desc = Pstr_value (Nonrecursive, bindings)} + | _ -> Ast_mapper.default_mapper.structure_item mapper str_item); structure = (fun mapper items -> let items = @@ -1519,6 +1537,17 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | ( Pexp_let + ( Recursive, + ({pvb_pat = {ppat_loc}} :: _ as bindings), + cont ), + RemoveRecFlag ) + when action.loc = ppat_loc -> + Some + { + expr with + pexp_desc = Pexp_let (Nonrecursive, bindings, cont); + } | ( Pexp_field ( {pexp_desc = Pexp_ident e}, {txt = Lident inner; loc} ), @@ -1634,7 +1663,8 @@ module Actions = struct | RemoveUnusedVariable -> List.mem "RemoveUnusedVariable" filter | RemoveUnusedType -> List.mem "RemoveUnusedType" filter - | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter) + | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter + | RemoveRecFlag -> List.mem "RemoveRecFlag" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 97e2d305fba87772319e935ff78a75aeb02b5f06 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 11:48:57 +0200 Subject: [PATCH 26/44] format --- tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res b/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res index 7c3ee1d2ccd..15dbc12e5c9 100644 --- a/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res +++ b/tests/build_tests/actions/fixtures/Actions_RemoveRecFlag.res @@ -1,5 +1,5 @@ // actionFilter=RemoveRecFlag let rec f = 12 let fn = () => { - let rec x = 12 -} \ No newline at end of file + let rec x = 12 +} From 6c0d8786996532c2ba1236a270e96ae871c83d4e Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:00:37 +0200 Subject: [PATCH 27/44] force open --- compiler/ext/warnings.ml | 2 -- compiler/ml/cmt_utils.ml | 4 +++ .../expected/Actions_ForceOpen_applied.res | 32 +++++++++++++++++++ .../actions/fixtures/Actions_ForceOpen.res | 26 +++++++++++++++ tools/src/tools.ml | 20 +++++++++++- 5 files changed, 81 insertions(+), 3 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_ForceOpen_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_ForceOpen.res diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 6a899bd7f55..47d0b71c382 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -440,12 +440,10 @@ let message = function ^ "\nThe first one was selected. Disambiguate if this is wrong." | Nonoptional_label s -> "the label " ^ s ^ " is not optional." | Open_shadow_identifier (kind, s) -> - (* TODO(actions) Force open *) Printf.sprintf "this open statement shadows the %s identifier %s (which is later used)" kind s | Open_shadow_label_constructor (kind, s) -> - (* TODO(actions) Force open *) Printf.sprintf "this open statement shadows the %s %s (which is later used)" kind s | Attribute_payload (a, s) -> diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index c901521ee2a..20ffcfc7084 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -47,6 +47,7 @@ type action_type = | RemoveUnusedType | RemoveUnusedModule | RemoveRecFlag + | ForceOpen (* TODO: - Unused var in patterns (and aliases )*) @@ -82,6 +83,7 @@ let action_to_string = function Printf.sprintf "RewriteIdent(%s)" (Longident.flatten new_ident |> String.concat ".") | RemoveRecFlag -> "RemoveRecFlag" + | ForceOpen -> "ForceOpen" let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action @@ -118,6 +120,8 @@ let emit_possible_actions_from_warning loc w = | Unused_rec_flag -> add_possible_action {loc; action = RemoveRecFlag; description = "Remove rec flag"} + | Open_shadow_identifier _ | Open_shadow_label_constructor _ -> + add_possible_action {loc; action = ForceOpen; description = "Force open"} | _ -> () let _ = diff --git a/tests/build_tests/actions/expected/Actions_ForceOpen_applied.res b/tests/build_tests/actions/expected/Actions_ForceOpen_applied.res new file mode 100644 index 00000000000..b2746b75151 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_ForceOpen_applied.res @@ -0,0 +1,32 @@ +type person = { + name: string, + age: int, +} + +module X = { + let ff = 15 +} + +let ff = 16 + +open! X + +let f2 = ff + +module RecordExample = { + type t = { + name: string, + age: int, + } + let person = {name: "John", age: 30} +} + +open! RecordExample + +let p = {name: "Jane", age: 25} + +/* === AVAILABLE ACTIONS: +- ForceOpen - Force open +- ForceOpen - Force open +- ForceOpen - Force open +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_ForceOpen.res b/tests/build_tests/actions/fixtures/Actions_ForceOpen.res new file mode 100644 index 00000000000..965c62eb8cf --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_ForceOpen.res @@ -0,0 +1,26 @@ +type person = { + name: string, + age: int, +} + +module X = { + let ff = 15 +} + +let ff = 16 + +open X + +let f2 = ff + +module RecordExample = { + type t = { + name: string, + age: int, + } + let person = {name: "John", age: 30} +} + +open RecordExample + +let p = {name: "Jane", age: 25} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 2f62de0b215..bfa8bdffa8b 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1309,7 +1309,24 @@ module Actions = struct | _ -> None) actions in + let force_open_action_locs = + List.filter_map + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | ForceOpen -> Some action.loc + | _ -> None) + actions + in match str_item.pstr_desc with + | Pstr_open ({popen_override = Fresh} as open_desc) + when List.mem str_item.pstr_loc force_open_action_locs -> + let str_item = + Ast_mapper.default_mapper.structure_item mapper str_item + in + { + str_item with + pstr_desc = Pstr_open {open_desc with popen_override = Override}; + } | Pstr_value (Recursive, ({pvb_pat = {ppat_loc}} :: _ as bindings)) when List.mem ppat_loc remove_rec_flag_action_locs -> let str_item = @@ -1664,7 +1681,8 @@ module Actions = struct List.mem "RemoveUnusedVariable" filter | RemoveUnusedType -> List.mem "RemoveUnusedType" filter | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter - | RemoveRecFlag -> List.mem "RemoveRecFlag" filter) + | RemoveRecFlag -> List.mem "RemoveRecFlag" filter + | ForceOpen -> List.mem "ForceOpen" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From c355f7c9564a06c78c33a2c64e108f5f79740607 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:06:40 +0200 Subject: [PATCH 28/44] cleanup --- compiler/ext/warnings.ml | 4 +--- compiler/ml/cmt_utils.ml | 16 +++++++++++++--- compiler/ml/env.ml | 2 -- compiler/ml/typecore.ml | 5 +---- compiler/ml/typetexp.ml | 3 +-- 5 files changed, 16 insertions(+), 14 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 47d0b71c382..341832200db 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -485,9 +485,7 @@ let message = function "Ambiguous or-pattern variables under guard;\n\ %s may match different arguments. (See manual section 8.5)" msg - | Unused_module s -> - (* TODO(actions) Remove module *) - "unused module " ^ s ^ "." + | Unused_module s -> "unused module " ^ s ^ "." | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." | Bs_unused_attribute s -> diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 20ffcfc7084..236270c0a6c 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -114,14 +114,24 @@ let emit_possible_actions_from_warning loc w = | Unused_module _ -> add_possible_action {loc; action = RemoveUnusedModule; description = "Remove unused module"} - | Unused_pat -> (* TODO: Remove full pattern. *) () - | Unused_argument -> - (* TODO(actions) Remove unused argument or prefix with underscore *) () | Unused_rec_flag -> add_possible_action {loc; action = RemoveRecFlag; description = "Remove rec flag"} | Open_shadow_identifier _ | Open_shadow_label_constructor _ -> add_possible_action {loc; action = ForceOpen; description = "Force open"} + (* + + === TODO === + + *) + | Fragile_literal_pattern -> + (* Use explicit pattern matching instead of literal *) () + | Unused_pat -> (* Remove pattern *) () + | Unused_argument -> (* Remove unused argument or prefix with underscore *) () + | Useless_record_with -> (* Remove `...` spread *) () + | Nonoptional_label _ -> (* Add `?` to make argument optional *) () + | Bs_toplevel_expression_unit _ -> + (* Assign to let _ = or pipe to ignore() *) () | _ -> () let _ = diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 5cd43e31791..970634be03d 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1660,7 +1660,6 @@ and store_type ~check id info env = if not (ty = "" || ty.[0] = '_') then Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then - (* TODO(actions) Remove unused constructor *) Location.prerr_warning loc (Warnings.Unused_constructor (c, used.cu_pattern, used.cu_privatize))))) @@ -1706,7 +1705,6 @@ and store_extension ~check id ext env = Hashtbl.add used_constructors k (add_constructor_usage used); Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then - (* TODO(actions) Remove unused extension *) Location.prerr_warning loc (Warnings.Unused_extension (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize))))); diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 448568d5298..c495d37d710 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1404,7 +1404,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (match sargs with | [({ppat_desc = Ppat_constant _} as sp)] when Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes -> - (* TODO(actions) Use explicit pattern matching instead of literal *) Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern | _ -> ()); if List.length sargs <> constr.cstr_arity then @@ -2785,7 +2784,6 @@ and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected) in let opt_exp = if List.length lid_sexp_list = num_fields then ( - (* TODO(actions) Remove `...` spread *) Location.prerr_warning loc Warnings.Useless_record_with; None) else opt_exp @@ -3724,7 +3722,7 @@ and type_application ~context total_app env funct (sargs : sargs) : Some (fun () -> option_none (instance env ty) Location.none) )) else (sargs, (l, ty, lv) :: omitted, None) | Some (l', sarg0, sargs) -> - if (not optional) && is_optional l' then + if (not optional) && is_optional_loc l' then (* TODO(actions) Add ? to make argument optional *) Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); @@ -4316,7 +4314,6 @@ let type_expression ~context env sexp = | Pexp_apply _ -> Some (return_type, FunctionCall) | _ -> Some (return_type, Other))) | Tags _ -> - (* TODO(actions) Assign to let _ = or pipe to ignore() *) Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); end_def (); if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 3e3cb2f9570..1fd7cd3e687 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -733,7 +733,6 @@ let did_you_mean ppf choices : bool * string list = match choices () with | [] -> (false, []) | last :: rev_rest as choices -> - (* TODO(actions) Rewrite ident *) Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" (String.concat ", " (List.rev rev_rest)) (if rev_rest = [] then "" else " or ") @@ -780,7 +779,7 @@ let report_error env ppf = function Printtyp.longident lid; let has_candidate, _ = super_spellcheck ppf Env.fold_types env lid in if not has_candidate then - (* TODO(actions) Add rec flag *) + (* TODO(actions) Add rec flag by first checking the let bindings for matching name *) Format.fprintf ppf "If you wanted to write a recursive type, don't forget the `rec` in \ `type rec`@]" From 04b8cbcac591721df50c72fbfc2bf5170b7747d8 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:12:10 +0200 Subject: [PATCH 29/44] remove record spread --- compiler/ml/cmt_utils.ml | 6 +++++- .../expected/Actions_RemoveRecordSpread_applied.res | 9 +++++++++ .../actions/fixtures/Actions_RemoveRecordSpread.res | 5 +++++ tools/src/tools.ml | 9 ++++++++- 4 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_RemoveRecordSpread_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_RemoveRecordSpread.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 236270c0a6c..0d47b0d7931 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -47,6 +47,7 @@ type action_type = | RemoveUnusedType | RemoveUnusedModule | RemoveRecFlag + | RemoveRecordSpread | ForceOpen (* TODO: @@ -84,6 +85,7 @@ let action_to_string = function (Longident.flatten new_ident |> String.concat ".") | RemoveRecFlag -> "RemoveRecFlag" | ForceOpen -> "ForceOpen" + | RemoveRecordSpread -> "RemoveRecordSpread" let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action @@ -119,6 +121,9 @@ let emit_possible_actions_from_warning loc w = {loc; action = RemoveRecFlag; description = "Remove rec flag"} | Open_shadow_identifier _ | Open_shadow_label_constructor _ -> add_possible_action {loc; action = ForceOpen; description = "Force open"} + | Useless_record_with -> + add_possible_action + {loc; action = RemoveRecordSpread; description = "Remove `...` spread"} (* === TODO === @@ -128,7 +133,6 @@ let emit_possible_actions_from_warning loc w = (* Use explicit pattern matching instead of literal *) () | Unused_pat -> (* Remove pattern *) () | Unused_argument -> (* Remove unused argument or prefix with underscore *) () - | Useless_record_with -> (* Remove `...` spread *) () | Nonoptional_label _ -> (* Add `?` to make argument optional *) () | Bs_toplevel_expression_unit _ -> (* Assign to let _ = or pipe to ignore() *) () diff --git a/tests/build_tests/actions/expected/Actions_RemoveRecordSpread_applied.res b/tests/build_tests/actions/expected/Actions_RemoveRecordSpread_applied.res new file mode 100644 index 00000000000..23603dde2f8 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_RemoveRecordSpread_applied.res @@ -0,0 +1,9 @@ +type x = {a: int} + +let x = {a: 1} + +let f = {a: 1} + +/* === AVAILABLE ACTIONS: +- RemoveRecordSpread - Remove `...` spread +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_RemoveRecordSpread.res b/tests/build_tests/actions/fixtures/Actions_RemoveRecordSpread.res new file mode 100644 index 00000000000..434279bbfc0 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_RemoveRecordSpread.res @@ -0,0 +1,5 @@ +type x = {a: int} + +let x = {a: 1} + +let f = {...x, a: 1} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index bfa8bdffa8b..e952cc2a44f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1458,6 +1458,12 @@ module Actions = struct if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | RemoveRecordSpread -> ( + match expr with + | {pexp_desc = Pexp_record (fields, Some _)} -> + Some + {expr with pexp_desc = Pexp_record (fields, None)} + | _ -> None) | RewriteIdent {new_ident} -> ( match expr with | {pexp_desc = Pexp_ident ident} -> @@ -1682,7 +1688,8 @@ module Actions = struct | RemoveUnusedType -> List.mem "RemoveUnusedType" filter | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter | RemoveRecFlag -> List.mem "RemoveRecFlag" filter - | ForceOpen -> List.mem "ForceOpen" filter) + | ForceOpen -> List.mem "ForceOpen" filter + | RemoveRecordSpread -> List.mem "RemoveRecordSpread" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 096d8f89660018d0cca3186c95e9856e57ac9b97 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:15:00 +0200 Subject: [PATCH 30/44] remove irrelevant --- compiler/ml/cmt_utils.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 0d47b0d7931..b4060b804ff 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -129,8 +129,6 @@ let emit_possible_actions_from_warning loc w = === TODO === *) - | Fragile_literal_pattern -> - (* Use explicit pattern matching instead of literal *) () | Unused_pat -> (* Remove pattern *) () | Unused_argument -> (* Remove unused argument or prefix with underscore *) () | Nonoptional_label _ -> (* Add `?` to make argument optional *) () From c9815f542dbd0625789edc888495680c79069753 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:30:05 +0200 Subject: [PATCH 31/44] handle top level --- compiler/ext/warnings.ml | 2 - compiler/ml/cmt_utils.ml | 9 +++- .../Actions_AssignToUnderscore_applied.res | 8 +++ .../expected/Actions_PipeToIgnore_applied.res | 8 +++ .../fixtures/Actions_AssignToUnderscore.res | 4 ++ .../actions/fixtures/Actions_PipeToIgnore.res | 4 ++ tools/src/tools.ml | 51 ++++++++++++++++++- 7 files changed, 82 insertions(+), 4 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res create mode 100644 tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_AssignToUnderscore.res create mode 100644 tests/build_tests/actions/fixtures/Actions_PipeToIgnore.res diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 341832200db..407c78f2955 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -508,8 +508,6 @@ let message = function "Integer literal exceeds the range of representable integers of type int" | Bs_uninterpreted_delimiters s -> "Uninterpreted delimiters " ^ s | Bs_toplevel_expression_unit help -> - (* TODO(actions) Assign to `let _ =` *) - (* TODO(actions) Ignore *) Printf.sprintf "This%sis at the top level and is expected to return `unit`. But it's \ returning %s.\n\n\ diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index b4060b804ff..965429b09e2 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -49,6 +49,8 @@ type action_type = | RemoveRecFlag | RemoveRecordSpread | ForceOpen + | AssignToUnderscore + | PipeToIgnore (* TODO: - Unused var in patterns (and aliases )*) @@ -86,6 +88,8 @@ let action_to_string = function | RemoveRecFlag -> "RemoveRecFlag" | ForceOpen -> "ForceOpen" | RemoveRecordSpread -> "RemoveRecordSpread" + | AssignToUnderscore -> "AssignToUnderscore" + | PipeToIgnore -> "PipeToIgnore" let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action @@ -133,7 +137,10 @@ let emit_possible_actions_from_warning loc w = | Unused_argument -> (* Remove unused argument or prefix with underscore *) () | Nonoptional_label _ -> (* Add `?` to make argument optional *) () | Bs_toplevel_expression_unit _ -> - (* Assign to let _ = or pipe to ignore() *) () + add_possible_action + {loc; action = PipeToIgnore; description = "Pipe to ignore()"}; + add_possible_action + {loc; action = AssignToUnderscore; description = "Assign to let _ ="} | _ -> () let _ = diff --git a/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res new file mode 100644 index 00000000000..9a0bc40eb3a --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res @@ -0,0 +1,8 @@ +let _ = // actionFilter=AssignToUnderscore +switch 1 { +| _ => "one" +} + +/* === AVAILABLE ACTIONS: +- AssignToUnderscore - Assign to let _ = +*/ diff --git a/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res b/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res new file mode 100644 index 00000000000..65175a6061e --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res @@ -0,0 +1,8 @@ +// actionFilter=PipeToIgnore +switch 1 { +| _ => "one" +}->ignore + +/* === AVAILABLE ACTIONS: +- PipeToIgnore - Pipe to ignore() +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_AssignToUnderscore.res b/tests/build_tests/actions/fixtures/Actions_AssignToUnderscore.res new file mode 100644 index 00000000000..31495f7ba2c --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_AssignToUnderscore.res @@ -0,0 +1,4 @@ +// actionFilter=AssignToUnderscore +switch 1 { +| _ => "one" +} diff --git a/tests/build_tests/actions/fixtures/Actions_PipeToIgnore.res b/tests/build_tests/actions/fixtures/Actions_PipeToIgnore.res new file mode 100644 index 00000000000..d5a735c59c7 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_PipeToIgnore.res @@ -0,0 +1,4 @@ +// actionFilter=PipeToIgnore +switch 1 { +| _ => "one" +} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index e952cc2a44f..70717b50857 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1317,7 +1317,32 @@ module Actions = struct | _ -> None) actions in + let assign_to_underscore_action_locs = + List.filter_map + (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | AssignToUnderscore -> Some action.loc + | _ -> None) + actions + in match str_item.pstr_desc with + | Pstr_eval (({pexp_loc} as e), attrs) + when List.mem pexp_loc assign_to_underscore_action_locs -> + let str_item = + Ast_mapper.default_mapper.structure_item mapper str_item + in + let loc = str_item.pstr_loc in + { + str_item with + pstr_desc = + Pstr_value + ( Nonrecursive, + [ + Ast_helper.Vb.mk ~loc ~attrs + (Ast_helper.Pat.var ~loc (Location.mkloc "_" loc)) + e; + ] ); + } | Pstr_open ({popen_override = Fresh} as open_desc) when List.mem str_item.pstr_loc force_open_action_locs -> let str_item = @@ -1458,6 +1483,28 @@ module Actions = struct if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in match action.action with + | PipeToIgnore -> + Some + { + expr with + pexp_desc = + Pexp_apply + { + funct = + Ast_helper.Exp.ident + (Location.mknoloc (Longident.Lident "->")); + partial = false; + transformed_jsx = false; + args = + [ + (Nolabel, expr); + ( Nolabel, + Ast_helper.Exp.ident + (Location.mknoloc + (Longident.Lident "ignore")) ); + ]; + }; + } | RemoveRecordSpread -> ( match expr with | {pexp_desc = Pexp_record (fields, Some _)} -> @@ -1689,7 +1736,9 @@ module Actions = struct | RemoveUnusedModule -> List.mem "RemoveUnusedModule" filter | RemoveRecFlag -> List.mem "RemoveRecFlag" filter | ForceOpen -> List.mem "ForceOpen" filter - | RemoveRecordSpread -> List.mem "RemoveRecordSpread" filter) + | RemoveRecordSpread -> List.mem "RemoveRecordSpread" filter + | AssignToUnderscore -> List.mem "AssignToUnderscore" filter + | PipeToIgnore -> List.mem "PipeToIgnore" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From c012813c959cdaaeac5abb6913fc0d26a94ddc72 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:33:06 +0200 Subject: [PATCH 32/44] clenaup --- compiler/ext/warnings.ml | 5 +---- compiler/ml/cmt_utils.ml | 12 +++++++----- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 407c78f2955..b1125c5ad50 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -407,9 +407,7 @@ let message = function | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." - | Unused_constructor (s, false, false) -> - (* TODO(actions) Remove constructor *) - "unused constructor " ^ s ^ "." + | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." | Unused_constructor (s, true, _) -> "constructor " ^ s ^ " is never used to build values.\n\ @@ -489,7 +487,6 @@ let message = function | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." | Bs_unused_attribute s -> - (* TODO(actions) Remove attribute *) "Unused attribute: @" ^ s ^ "\n\ This attribute has no effect here.\n\ diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 965429b09e2..79dffac3517 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -128,6 +128,11 @@ let emit_possible_actions_from_warning loc w = | Useless_record_with -> add_possible_action {loc; action = RemoveRecordSpread; description = "Remove `...` spread"} + | Bs_toplevel_expression_unit _ -> + add_possible_action + {loc; action = PipeToIgnore; description = "Pipe to ignore()"}; + add_possible_action + {loc; action = AssignToUnderscore; description = "Assign to let _ ="} (* === TODO === @@ -135,12 +140,9 @@ let emit_possible_actions_from_warning loc w = *) | Unused_pat -> (* Remove pattern *) () | Unused_argument -> (* Remove unused argument or prefix with underscore *) () + | Unused_constructor _ -> (* Remove unused constructor *) () | Nonoptional_label _ -> (* Add `?` to make argument optional *) () - | Bs_toplevel_expression_unit _ -> - add_possible_action - {loc; action = PipeToIgnore; description = "Pipe to ignore()"}; - add_possible_action - {loc; action = AssignToUnderscore; description = "Assign to let _ ="} + | Bs_unused_attribute _ -> (* Remove unused attribute *) () | _ -> () let _ = From cd5f2e27e36742f2f63099ff3f5c017a4980d485 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 13:45:18 +0200 Subject: [PATCH 33/44] emit all available actions into applied file, not just the filtered ones --- .../actions/expected/Actions_AssignToUnderscore_applied.res | 1 + .../actions/expected/Actions_PipeToIgnore_applied.res | 1 + .../expected/Actions_PrefixUnusedVarUnderscore_applied.res | 1 + .../actions/expected/Actions_RemoveRecFlag_applied.res | 2 ++ .../actions/expected/Actions_RemoveUnusedModule_applied.res | 2 ++ .../actions/expected/Actions_RemoveUnusedValue_applied.res | 1 + .../actions/expected/Actions_RemoveUnusedVar_applied.res | 1 + tools/src/tools.ml | 2 +- 8 files changed, 10 insertions(+), 1 deletion(-) diff --git a/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res index 9a0bc40eb3a..964847798aa 100644 --- a/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res +++ b/tests/build_tests/actions/expected/Actions_AssignToUnderscore_applied.res @@ -5,4 +5,5 @@ switch 1 { /* === AVAILABLE ACTIONS: - AssignToUnderscore - Assign to let _ = +- PipeToIgnore - Pipe to ignore() */ diff --git a/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res b/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res index 65175a6061e..a31b78fdf25 100644 --- a/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res +++ b/tests/build_tests/actions/expected/Actions_PipeToIgnore_applied.res @@ -4,5 +4,6 @@ switch 1 { }->ignore /* === AVAILABLE ACTIONS: +- AssignToUnderscore - Assign to let _ = - PipeToIgnore - Pipe to ignore() */ diff --git a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res index 0214add773f..08ab3a728da 100644 --- a/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res +++ b/tests/build_tests/actions/expected/Actions_PrefixUnusedVarUnderscore_applied.res @@ -5,5 +5,6 @@ let f = () => { } /* === AVAILABLE ACTIONS: +- RemoveUnusedVariable - Remove unused variable - PrefixVariableWithUnderscore - Prefix with `_` */ diff --git a/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res b/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res index 9ba4ea151bc..2397491daee 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveRecFlag_applied.res @@ -5,6 +5,8 @@ let fn = () => { } /* === AVAILABLE ACTIONS: +- RemoveUnusedVariable - Remove unused variable +- PrefixVariableWithUnderscore - Prefix with `_` - RemoveRecFlag - Remove rec flag - RemoveRecFlag - Remove rec flag */ diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res index 16b1575b07b..3605fa5032e 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedModule_applied.res @@ -3,4 +3,6 @@ module M: {} = {} /* === AVAILABLE ACTIONS: - RemoveUnusedModule - Remove unused module +- RemoveUnusedVariable - Remove unused variable +- PrefixVariableWithUnderscore - Prefix with `_` */ diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res index 44fc18dd3e0..38591b776d2 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedValue_applied.res @@ -3,4 +3,5 @@ module M: {} = {} /* === AVAILABLE ACTIONS: - RemoveUnusedVariable - Remove unused variable +- PrefixVariableWithUnderscore - Prefix with `_` */ diff --git a/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res index 49ff8b31610..6bd09330763 100644 --- a/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res +++ b/tests/build_tests/actions/expected/Actions_RemoveUnusedVar_applied.res @@ -5,4 +5,5 @@ let f = () => { /* === AVAILABLE ACTIONS: - RemoveUnusedVariable - Remove unused variable +- PrefixVariableWithUnderscore - Prefix with `_` */ diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 70717b50857..4417add6529 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1744,7 +1744,7 @@ module Actions = struct | Ok applied -> print_endline applied; print_endline "/* === AVAILABLE ACTIONS:"; - possible_actions + cmt_possible_actions |> List.iter (fun (action : Cmt_utils.cmt_action) -> Printf.printf "- %s - %s\n" (Cmt_utils.action_to_string action.action) From a47179533195f8321d9fa5d423e623f2333cd0ee Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:46:39 +0200 Subject: [PATCH 34/44] make optional arg labelled --- compiler/ml/cmt_utils.ml | 14 ++++++- .../Actions_MakeArgNonOptional_applied.res | 9 +++++ .../fixtures/Actions_MakeArgNonOptional.res | 5 +++ tools/src/tools.ml | 37 ++++++++++++++++++- 4 files changed, 63 insertions(+), 2 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_MakeArgNonOptional_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_MakeArgNonOptional.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 79dffac3517..1812b2c864e 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -42,6 +42,7 @@ type action_type = | RewriteArrayToTuple | RewriteIdentToModule of {module_name: string} | RewriteIdent of {new_ident: Longident.t} + | RewriteArgType of {to_type: [`Labelled | `Optional | `Unlabelled]} | PrefixVariableWithUnderscore | RemoveUnusedVariable | RemoveUnusedType @@ -90,6 +91,11 @@ let action_to_string = function | RemoveRecordSpread -> "RemoveRecordSpread" | AssignToUnderscore -> "AssignToUnderscore" | PipeToIgnore -> "PipeToIgnore" + | RewriteArgType {to_type} -> ( + match to_type with + | `Labelled -> "RewriteArgType(Labelled)" + | `Optional -> "RewriteArgType(Optional)" + | `Unlabelled -> "RewriteArgType(Unlabelled)") let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action @@ -133,6 +139,13 @@ let emit_possible_actions_from_warning loc w = {loc; action = PipeToIgnore; description = "Pipe to ignore()"}; add_possible_action {loc; action = AssignToUnderscore; description = "Assign to let _ ="} + | Nonoptional_label _ -> + add_possible_action + { + loc; + action = RewriteArgType {to_type = `Labelled}; + description = "Make argument optional"; + } (* === TODO === @@ -141,7 +154,6 @@ let emit_possible_actions_from_warning loc w = | Unused_pat -> (* Remove pattern *) () | Unused_argument -> (* Remove unused argument or prefix with underscore *) () | Unused_constructor _ -> (* Remove unused constructor *) () - | Nonoptional_label _ -> (* Add `?` to make argument optional *) () | Bs_unused_attribute _ -> (* Remove unused attribute *) () | _ -> () diff --git a/tests/build_tests/actions/expected/Actions_MakeArgNonOptional_applied.res b/tests/build_tests/actions/expected/Actions_MakeArgNonOptional_applied.res new file mode 100644 index 00000000000..cf9ab078a6b --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_MakeArgNonOptional_applied.res @@ -0,0 +1,9 @@ +let myFunction = (~name: string) => { + ignore(name) +} +let name = "John" +myFunction(~name) + +/* === AVAILABLE ACTIONS: +- RewriteArgType(Labelled) - Make argument optional +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_MakeArgNonOptional.res b/tests/build_tests/actions/fixtures/Actions_MakeArgNonOptional.res new file mode 100644 index 00000000000..daa6d2c4359 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_MakeArgNonOptional.res @@ -0,0 +1,5 @@ +let myFunction = (~name: string) => { + ignore(name) +} +let name = "John" +myFunction(~name?) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 4417add6529..071d5993369 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1607,6 +1607,40 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | Pexp_apply ({args} as apply), RewriteArgType {to_type} + -> + let arg_locs = + args + |> List.filter_map (fun (lbl, _e) -> + match lbl with + | Asttypes.Labelled {loc} | Optional {loc} -> + Some loc + | Nolabel -> None) + in + if List.mem action.loc arg_locs then + Some + { + expr with + pexp_desc = + Pexp_apply + { + apply with + args = + args + |> List.map (fun (lbl, e) -> + ( (match (lbl, to_type) with + | ( Asttypes.Optional {txt; loc}, + `Labelled ) -> + Asttypes.Labelled {txt; loc} + | ( Asttypes.Labelled {txt; loc}, + `Optional ) -> + Asttypes.Optional {txt; loc} + | _ -> lbl), + Ast_mapper.default_mapper.expr + mapper e )); + }; + } + else None | ( Pexp_let ( Recursive, ({pvb_pat = {ppat_loc}} :: _ as bindings), @@ -1738,7 +1772,8 @@ module Actions = struct | ForceOpen -> List.mem "ForceOpen" filter | RemoveRecordSpread -> List.mem "RemoveRecordSpread" filter | AssignToUnderscore -> List.mem "AssignToUnderscore" filter - | PipeToIgnore -> List.mem "PipeToIgnore" filter) + | PipeToIgnore -> List.mem "PipeToIgnore" filter + | RewriteArgType _ -> List.mem "RewriteArgType" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From d5f73de672b5b43032019d47c9b9c15c68a8f3eb Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:49:55 +0200 Subject: [PATCH 35/44] labelled to optional arg --- compiler/ml/error_message_utils.ml | 7 ++++++- .../actions/expected/Actions_MakeArgOptional_applied.res | 9 +++++++++ .../actions/fixtures/Actions_MakeArgOptional.res | 5 +++++ 3 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/actions/expected/Actions_MakeArgOptional_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_MakeArgOptional.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 5ad22f41cc8..bfa34ba2bb2 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -627,7 +627,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (FunctionArgument {optional = true}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> - (* TODO(actions) Prepend with `?` *) + Cmt_utils.add_possible_action + { + loc; + action = RewriteArgType {to_type = `Optional}; + description = "Make argument optional"; + }; fprintf ppf "@,\ @,\ diff --git a/tests/build_tests/actions/expected/Actions_MakeArgOptional_applied.res b/tests/build_tests/actions/expected/Actions_MakeArgOptional_applied.res new file mode 100644 index 00000000000..21458bc8099 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_MakeArgOptional_applied.res @@ -0,0 +1,9 @@ +let myFunction = (~name: option=?) => { + ignore(name) +} +let name = Some("John") +myFunction(~name?) + +/* === AVAILABLE ACTIONS: +- RewriteArgType(Optional) - Make argument optional +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_MakeArgOptional.res b/tests/build_tests/actions/fixtures/Actions_MakeArgOptional.res new file mode 100644 index 00000000000..9c8a4e4e65d --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_MakeArgOptional.res @@ -0,0 +1,5 @@ +let myFunction = (~name: option=?) => { + ignore(name) +} +let name = Some("John") +myFunction(~name) From 82ad5e8c0cdc2efaeaf09e1f20b7b2d2d2848fd6 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:56:32 +0200 Subject: [PATCH 36/44] partially apply function --- compiler/ml/cmt_utils.ml | 2 ++ compiler/ml/typecore.ml | 9 +++++++-- .../Actions_PartiallyApplyFunction_applied.res | 7 +++++++ .../fixtures/Actions_PartiallyApplyFunction.res | 3 +++ tools/src/tools.ml | 11 +++++++++++ 5 files changed, 30 insertions(+), 2 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_PartiallyApplyFunction.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 1812b2c864e..a8bcd649301 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -52,6 +52,7 @@ type action_type = | ForceOpen | AssignToUnderscore | PipeToIgnore + | PartiallyApplyFunction (* TODO: - Unused var in patterns (and aliases )*) @@ -96,6 +97,7 @@ let action_to_string = function | `Labelled -> "RewriteArgType(Labelled)" | `Optional -> "RewriteArgType(Optional)" | `Unlabelled -> "RewriteArgType(Unlabelled)") + | PartiallyApplyFunction -> "PartiallyApplyFunction" let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index c495d37d710..a7bc73448d6 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4723,11 +4723,16 @@ let report_error env loc ppf error = if List.length missing_required_args > 0 then ( (* TODO(actions) Add missing arguments *) - (* TODO(actions) Partially apply *) + Cmt_utils.add_possible_action + { + loc; + action = PartiallyApplyFunction; + description = "Partially apply function"; + }; fprintf ppf "@,- Missing arguments that must be provided: %s" (missing_required_args |> List.map (fun v -> "~" ^ v) - |> String.concat ", "); + |> String.concat ", ")); fprintf ppf "@,\ diff --git a/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res b/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res new file mode 100644 index 00000000000..069389af17a --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res @@ -0,0 +1,7 @@ +// actionFilter=PartiallyApplyFunction +let x = (~a, ~b) => a + b +let y = x(~a=2, ...) + 2 + +/* === AVAILABLE ACTIONS: +- PartiallyApplyFunction - Partially apply function +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_PartiallyApplyFunction.res b/tests/build_tests/actions/fixtures/Actions_PartiallyApplyFunction.res new file mode 100644 index 00000000000..f608aa3beaa --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_PartiallyApplyFunction.res @@ -0,0 +1,3 @@ +// actionFilter=PartiallyApplyFunction +let x = (~a, ~b) => a + b +let y = x(~a=2) + 2 diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 071d5993369..80da0cb9aef 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1607,6 +1607,15 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | ( Pexp_apply ({funct} as apply_args), + PartiallyApplyFunction ) + when funct.pexp_loc = action.loc -> + Some + { + expr with + pexp_desc = + Pexp_apply {apply_args with partial = true}; + } | Pexp_apply ({args} as apply), RewriteArgType {to_type} -> let arg_locs = @@ -1773,6 +1782,8 @@ module Actions = struct | RemoveRecordSpread -> List.mem "RemoveRecordSpread" filter | AssignToUnderscore -> List.mem "AssignToUnderscore" filter | PipeToIgnore -> List.mem "PipeToIgnore" filter + | PartiallyApplyFunction -> + List.mem "PartiallyApplyFunction" filter | RewriteArgType _ -> List.mem "RewriteArgType" filter) in match applyActionsToFile path possible_actions with From fe42237502fcbf779f082f5c9255a7e225480867 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 15:07:59 +0200 Subject: [PATCH 37/44] add missing args --- compiler/ml/cmt_utils.ml | 10 +++++++++ compiler/ml/typecore.ml | 13 +++++++++++- ...Actions_InsertMissingArguments_applied.res | 8 +++++++ ...Actions_PartiallyApplyFunction_applied.res | 1 + .../Actions_InsertMissingArguments.res | 3 +++ tools/src/tools.ml | 21 ++++++++++++++++++- 6 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_InsertMissingArguments_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_InsertMissingArguments.res diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index a8bcd649301..c8cccf17381 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -53,6 +53,7 @@ type action_type = | AssignToUnderscore | PipeToIgnore | PartiallyApplyFunction + | InsertMissingArguments of {missing_args: Asttypes.Noloc.arg_label list} (* TODO: - Unused var in patterns (and aliases )*) @@ -98,6 +99,15 @@ let action_to_string = function | `Optional -> "RewriteArgType(Optional)" | `Unlabelled -> "RewriteArgType(Unlabelled)") | PartiallyApplyFunction -> "PartiallyApplyFunction" + | InsertMissingArguments {missing_args} -> + Printf.sprintf "InsertMissingArguments(%s)" + (missing_args + |> List.map (fun arg -> + match arg with + | Asttypes.Noloc.Labelled txt -> "~" ^ txt + | Asttypes.Noloc.Optional txt -> "?" ^ txt + | Asttypes.Noloc.Nolabel -> "") + |> String.concat ", ") let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a7bc73448d6..43774b4f2c3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4722,7 +4722,18 @@ let report_error env loc ppf error = if not is_fallback then fprintf ppf "@,"; if List.length missing_required_args > 0 then ( - (* TODO(actions) Add missing arguments *) + Cmt_utils.add_possible_action + { + loc; + action = + InsertMissingArguments + { + missing_args = + missing_required_args + |> List.map (fun arg -> Noloc.Labelled arg); + }; + description = "Insert missing arguments"; + }; Cmt_utils.add_possible_action { loc; diff --git a/tests/build_tests/actions/expected/Actions_InsertMissingArguments_applied.res b/tests/build_tests/actions/expected/Actions_InsertMissingArguments_applied.res new file mode 100644 index 00000000000..99123d0b8a1 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_InsertMissingArguments_applied.res @@ -0,0 +1,8 @@ +// actionFilter=InsertMissingArguments +let x = (~a, ~b) => a + b +let y = x(~a=2, ~b=%todo) + 2 + +/* === AVAILABLE ACTIONS: +- PartiallyApplyFunction - Partially apply function +- InsertMissingArguments(~b) - Insert missing arguments +*/ diff --git a/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res b/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res index 069389af17a..7d79033803b 100644 --- a/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res +++ b/tests/build_tests/actions/expected/Actions_PartiallyApplyFunction_applied.res @@ -4,4 +4,5 @@ let y = x(~a=2, ...) + 2 /* === AVAILABLE ACTIONS: - PartiallyApplyFunction - Partially apply function +- InsertMissingArguments(~b) - Insert missing arguments */ diff --git a/tests/build_tests/actions/fixtures/Actions_InsertMissingArguments.res b/tests/build_tests/actions/fixtures/Actions_InsertMissingArguments.res new file mode 100644 index 00000000000..79b617bdb48 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_InsertMissingArguments.res @@ -0,0 +1,3 @@ +// actionFilter=InsertMissingArguments +let x = (~a, ~b) => a + b +let y = x(~a=2) + 2 diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 80da0cb9aef..4feaff82a2b 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1607,6 +1607,23 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | ( Pexp_apply ({funct; args} as apply), + InsertMissingArguments {missing_args} ) + when funct.pexp_loc = action.loc -> + let args_to_insert = + missing_args + |> List.map (fun (lbl : Asttypes.Noloc.arg_label) -> + ( Asttypes.to_arg_label lbl, + Ast_helper.Exp.extension + (Location.mknoloc "todo", PStr []) )) + in + Some + { + expr with + pexp_desc = + Pexp_apply + {apply with args = args @ args_to_insert}; + } | ( Pexp_apply ({funct} as apply_args), PartiallyApplyFunction ) when funct.pexp_loc = action.loc -> @@ -1784,7 +1801,9 @@ module Actions = struct | PipeToIgnore -> List.mem "PipeToIgnore" filter | PartiallyApplyFunction -> List.mem "PartiallyApplyFunction" filter - | RewriteArgType _ -> List.mem "RewriteArgType" filter) + | RewriteArgType _ -> List.mem "RewriteArgType" filter + | InsertMissingArguments _ -> + List.mem "InsertMissingArguments" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 6c95205e86715b842bf22f4931523c2057827df3 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 16:17:56 +0200 Subject: [PATCH 38/44] pass record field expr as optional --- compiler/ml/ast_iterator.ml | 23 ++++++------- compiler/ml/ast_iterator.mli | 2 ++ compiler/ml/ast_mapper.ml | 21 ++++++------ compiler/ml/ast_mapper.mli | 3 ++ compiler/ml/cmt_utils.ml | 4 +++ compiler/ml/error_message_utils.ml | 9 +++-- ...ions_PassRecordFieldAsOptional_applied.res | 8 +++++ .../Actions_PassRecordFieldAsOptional.res | 4 +++ tools/src/tools.ml | 33 ++++++++++++++++++- 9 files changed, 83 insertions(+), 24 deletions(-) create mode 100644 tests/build_tests/actions/expected/Actions_PassRecordFieldAsOptional_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_PassRecordFieldAsOptional.res diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 6cfe602f392..d553b5d0622 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -44,6 +44,8 @@ type iterator = { open_description: iterator -> open_description -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; + record_field: iterator -> expression record_element -> unit; + record_field_pat: iterator -> pattern record_element -> unit; signature: iterator -> signature -> unit; signature_item: iterator -> signature_item -> unit; structure: iterator -> structure -> unit; @@ -309,11 +311,7 @@ module E = struct iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) -> - List.iter - (fun {lid; x = exp} -> - iter_loc sub lid; - sub.expr sub exp) - l; + List.iter (sub.record_field sub) l; iter_opt (sub.expr sub) eo | Pexp_field (e, lid) -> sub.expr sub e; @@ -399,12 +397,7 @@ module P = struct iter_loc sub l; iter_opt (sub.pat sub) p | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, _cf) -> - List.iter - (fun {lid; x = pat} -> - iter_loc sub lid; - sub.pat sub pat) - lpl + | Ppat_record (lpl, _cf) -> List.iter (sub.record_field_pat sub) lpl | Ppat_array pl -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; @@ -528,4 +521,12 @@ let default_iterator = | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g); + record_field = + (fun this {lid; x; opt = _} -> + iter_loc this lid; + this.expr this x); + record_field_pat = + (fun this {lid; x; opt = _} -> + iter_loc this lid; + this.pat this x); } diff --git a/compiler/ml/ast_iterator.mli b/compiler/ml/ast_iterator.mli index c63aa94b6de..1302b5ea1ae 100644 --- a/compiler/ml/ast_iterator.mli +++ b/compiler/ml/ast_iterator.mli @@ -42,6 +42,8 @@ type iterator = { open_description: iterator -> open_description -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; + record_field: iterator -> expression record_element -> unit; + record_field_pat: iterator -> pattern record_element -> unit; signature: iterator -> signature -> unit; signature_item: iterator -> signature_item -> unit; structure: iterator -> structure -> unit; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 27c8509f34d..d048c9cd088 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -48,6 +48,9 @@ type mapper = { open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; + record_field: + mapper -> expression record_element -> expression record_element; + record_field_pat: mapper -> pattern record_element -> pattern record_element; signature: mapper -> signature -> signature; signature_item: mapper -> signature_item -> signature_item; structure: mapper -> structure -> structure; @@ -305,10 +308,7 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map - (fun {lid; x = exp; opt} -> - {lid = map_loc sub lid; x = sub.expr sub exp; opt}) - l) + (List.map (sub.record_field sub) l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -391,12 +391,7 @@ module P = struct construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map - (fun {lid; x = pat; opt} -> - {lid = map_loc sub lid; x = sub.pat sub pat; opt}) - lpl) - cf + record ~loc ~attrs (List.map (sub.record_field_pat sub) lpl) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t) -> @@ -509,6 +504,12 @@ let default_mapper = | PSig x -> PSig (this.signature this x) | PTyp x -> PTyp (this.typ this x) | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + record_field = + (fun this {lid; x; opt} -> + {lid = map_loc this lid; x = this.expr this x; opt}); + record_field_pat = + (fun this {lid; x; opt} -> + {lid = map_loc this lid; x = this.pat this x; opt}); } let rec extension_of_error {loc; msg; if_highlight; sub} = diff --git a/compiler/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli index 15187501e37..299d59d5dea 100644 --- a/compiler/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -76,6 +76,9 @@ type mapper = { open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; + record_field: + mapper -> expression record_element -> expression record_element; + record_field_pat: mapper -> pattern record_element -> pattern record_element; signature: mapper -> signature -> signature; signature_item: mapper -> signature_item -> signature_item; structure: mapper -> structure -> structure; diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index c8cccf17381..9a95fd8a477 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -54,6 +54,7 @@ type action_type = | PipeToIgnore | PartiallyApplyFunction | InsertMissingArguments of {missing_args: Asttypes.Noloc.arg_label list} + | ChangeRecordFieldOptional of {optional: bool} (* TODO: - Unused var in patterns (and aliases )*) @@ -108,6 +109,9 @@ let action_to_string = function | Asttypes.Noloc.Optional txt -> "?" ^ txt | Asttypes.Noloc.Nolabel -> "") |> String.concat ", ") + | ChangeRecordFieldOptional {optional} -> + Printf.sprintf "ChangeRecordFieldOptional(%s)" + (if optional then "true" else "false") let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index bfa34ba2bb2..027fb70ff1b 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -589,7 +589,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (RecordField {optional = true; field_name; jsx = None}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> - (* TODO(actions) Prepend with `?` *) + Cmt_utils.add_possible_action + { + loc; + action = ChangeRecordFieldOptional {optional = true}; + description = "Pass field as optional"; + }; fprintf ppf "@,\ @,\ @@ -608,7 +613,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (RecordField {optional = true; field_name; jsx = Some _}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> - (* TODO(actions) Prepend with `?` *) + (* TODO(actions) JSX: Prepend with `?` *) fprintf ppf "@,\ @,\ diff --git a/tests/build_tests/actions/expected/Actions_PassRecordFieldAsOptional_applied.res b/tests/build_tests/actions/expected/Actions_PassRecordFieldAsOptional_applied.res new file mode 100644 index 00000000000..6c91a4a32df --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_PassRecordFieldAsOptional_applied.res @@ -0,0 +1,8 @@ +type record = {a: int, test?: bool} +let test = Some(true) + +let x = {a: 10, ?test} + +/* === AVAILABLE ACTIONS: +- ChangeRecordFieldOptional(true) - Pass field as optional +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_PassRecordFieldAsOptional.res b/tests/build_tests/actions/fixtures/Actions_PassRecordFieldAsOptional.res new file mode 100644 index 00000000000..c4d8af901b6 --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_PassRecordFieldAsOptional.res @@ -0,0 +1,4 @@ +type record = {a: int, test?: bool} +let test = Some(true) + +let x = {a: 10, test} diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 4feaff82a2b..ad1339c30ab 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1295,10 +1295,39 @@ end module Migrate = Migrate module Actions = struct + let change_record_field_optional (record_el : _ Parsetree.record_element) + target_loc actions = + let change_record_field_optional_action = + actions + |> List.find_map (fun (action : Cmt_utils.cmt_action) -> + match action.action with + | ChangeRecordFieldOptional {optional} when target_loc = action.loc + -> + Some optional + | _ -> None) + in + match change_record_field_optional_action with + | Some opt -> {record_el with opt} + | None -> record_el + let applyActionsToFile path actions = let mapper = { Ast_mapper.default_mapper with + record_field = + (fun mapper record_el -> + let record_el = + change_record_field_optional record_el record_el.x.pexp_loc + actions + in + Ast_mapper.default_mapper.record_field mapper record_el); + record_field_pat = + (fun mapper record_el -> + let record_el = + change_record_field_optional record_el record_el.x.ppat_loc + actions + in + Ast_mapper.default_mapper.record_field_pat mapper record_el); structure_item = (fun mapper str_item -> let remove_rec_flag_action_locs = @@ -1803,7 +1832,9 @@ module Actions = struct List.mem "PartiallyApplyFunction" filter | RewriteArgType _ -> List.mem "RewriteArgType" filter | InsertMissingArguments _ -> - List.mem "InsertMissingArguments" filter) + List.mem "InsertMissingArguments" filter + | ChangeRecordFieldOptional _ -> + List.mem "ChangeRecordFieldOptional" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 61aec54fbe34b20a0905b4e480d5232a4ef6670c Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 29 Jul 2025 22:42:16 +0200 Subject: [PATCH 39/44] add action for automatically unwrapping record field access through option --- compiler/ml/cmt_utils.ml | 4 ++++ compiler/ml/typetexp.ml | 36 +++++++++++++++++++++--------- compiler/ml/typetexp.mli | 6 ++++- tools/src/tools.ml | 48 +++++++++++++++++++++++++++++++++++++++- 4 files changed, 82 insertions(+), 12 deletions(-) diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 9a95fd8a477..f3294fa0d2e 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -55,6 +55,7 @@ type action_type = | PartiallyApplyFunction | InsertMissingArguments of {missing_args: Asttypes.Noloc.arg_label list} | ChangeRecordFieldOptional of {optional: bool} + | UnwrapOptionMapRecordField of {field_name: Longident.t} (* TODO: - Unused var in patterns (and aliases )*) @@ -112,6 +113,9 @@ let action_to_string = function | ChangeRecordFieldOptional {optional} -> Printf.sprintf "ChangeRecordFieldOptional(%s)" (if optional then "true" else "false") + | UnwrapOptionMapRecordField {field_name} -> + Printf.sprintf "UnwrapOptionMapRecordField(%s)" + (Longident.flatten field_name |> String.concat ".") let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 1fd7cd3e687..4e0ac96f73d 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -43,7 +43,11 @@ type error = | Method_mismatch of string * type_expr * type_expr | Unbound_value of Longident.t * Location.t | Unbound_constructor of Longident.t - | Unbound_label of Longident.t * type_expr option + | Unbound_label of { + loc: Location.t; + field_name: Longident.t; + from_type: type_expr option; + } | Unbound_module of Longident.t | Unbound_modtype of Longident.t | Ill_typed_functor_application of Longident.t @@ -129,8 +133,10 @@ let find_constructor = let find_all_constructors = find_component Env.lookup_all_constructors (fun lid -> Unbound_constructor lid) -let find_all_labels = - find_component Env.lookup_all_labels (fun lid -> Unbound_label (lid, None)) +let find_all_labels env loc = + find_component Env.lookup_all_labels + (fun lid -> Unbound_label {loc; field_name = lid; from_type = None}) + env loc let find_value ?deprecated_context env loc lid = Env.check_value_name (Longident.last lid) loc; @@ -170,8 +176,9 @@ let unbound_constructor_error ?from_type env lid = Unbound_constructor lid) let unbound_label_error ?from_type env lid = + let lid_with_loc = lid in narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> - Unbound_label (lid, from_type)) + Unbound_label {loc = lid_with_loc.loc; field_name = lid; from_type}) (* Support for first-class modules. *) @@ -938,10 +945,17 @@ let report_error env ppf = function = Bar@}.@]@]" Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid; spellcheck ppf fold_constructors env lid - | Unbound_label (lid, from_type) -> + | Unbound_label {loc; field_name; from_type} -> (* modified *) (match from_type with | Some {desc = Tconstr (p, _, _)} when Path.same p Predef.path_option -> + Cmt_utils.add_possible_action + { + loc; + action = UnwrapOptionMapRecordField {field_name}; + description = + "Unwrap the option first before accessing the record field"; + }; (* TODO: Extend for nullable/null? *) Format.fprintf ppf "@[You're trying to access the record field @{%a@}, but the \ @@ -953,14 +967,15 @@ let report_error env ppf = function @{xx->Option.map(field => field.%a)@}@]@,\ @[- Or use @{Option.getOr@} with a default: \ @{xx->Option.getOr(defaultRecord).%a@}@]@]" - Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid + Printtyp.longident field_name Printtyp.longident field_name + Printtyp.longident field_name | Some {desc = Tconstr (p, _, _)} when Path.same p Predef.path_array -> Format.fprintf ppf "@[You're trying to access the record field @{%a@}, but the \ value you're trying to access it on is an @{array@}.@ You need \ to access an individual element of the array if you want to access an \ individual record field.@]" - Printtyp.longident lid + Printtyp.longident field_name | Some ({desc = Tconstr (_p, _, _)} as t1) -> Format.fprintf ppf "@[You're trying to access the record field @{%a@}, but the \ @@ -969,7 +984,7 @@ let report_error env ppf = function %a@,\n\ @,\ Only records have fields that can be accessed with dot notation.@]" - Printtyp.longident lid Error_message_utils.type_expr t1 + Printtyp.longident field_name Error_message_utils.type_expr t1 | None | Some _ -> Format.fprintf ppf "@[@{%a@} refers to a record field, but no corresponding \ @@ -980,8 +995,9 @@ let report_error env ppf = function @{TheModule.%a@}@]@,\ @[- Or specifying the record type explicitly:@ @{let theValue: \ TheModule.theType = {%a: VALUE}@}@]@]" - Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid); - spellcheck ppf fold_labels env lid + Printtyp.longident field_name Printtyp.longident field_name + Printtyp.longident field_name); + spellcheck ppf fold_labels env field_name | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid; spellcheck ppf fold_modtypes env lid diff --git a/compiler/ml/typetexp.mli b/compiler/ml/typetexp.mli index ce814c2fb9c..b9cd68c0d62 100644 --- a/compiler/ml/typetexp.mli +++ b/compiler/ml/typetexp.mli @@ -52,7 +52,11 @@ type error = | Method_mismatch of string * type_expr * type_expr | Unbound_value of Longident.t * Location.t | Unbound_constructor of Longident.t - | Unbound_label of Longident.t * type_expr option + | Unbound_label of { + loc: Location.t; + field_name: Longident.t; + from_type: type_expr option; + } | Unbound_module of Longident.t | Unbound_modtype of Longident.t | Ill_typed_functor_application of Longident.t diff --git a/tools/src/tools.ml b/tools/src/tools.ml index ad1339c30ab..254e0b91b44 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1294,6 +1294,24 @@ module ExtractCodeblocks = struct end module Migrate = Migrate +module TemplateUtils = struct + let get_expr source = + let {Res_driver.parsetree; invalid} = + Res_driver.parse_implementation_from_source ~for_printer:true + ~display_filename:"" ~source + in + if invalid then Error "Could not parse expression" + else + match parsetree with + | [{pstr_desc = Pstr_eval (e, _)}] -> Ok e + | _ -> Error "Expected a record expression" + + let get_expr_exn source = + match get_expr source with + | Ok e -> e + | Error e -> failwith e +end + module Actions = struct let change_record_field_optional (record_el : _ Parsetree.record_element) target_loc actions = @@ -1636,6 +1654,32 @@ module Actions = struct else (* Other cases when the loc is on something else in the expr *) match (expr.pexp_desc, action.action) with + | ( Pexp_field (e, {loc}), + UnwrapOptionMapRecordField {field_name} ) + when action.loc = loc -> + Some + { + expr with + pexp_desc = + Pexp_apply + { + funct = + Ast_helper.Exp.ident + (Location.mknoloc (Longident.Lident "->")); + partial = false; + transformed_jsx = false; + args = + [ + (Nolabel, e); + ( Nolabel, + TemplateUtils.get_expr_exn + (Printf.sprintf + "Option.map(v => v.%s)" + (Longident.flatten field_name + |> String.concat ".")) ); + ]; + }; + } | ( Pexp_apply ({funct; args} as apply), InsertMissingArguments {missing_args} ) when funct.pexp_loc = action.loc -> @@ -1834,7 +1878,9 @@ module Actions = struct | InsertMissingArguments _ -> List.mem "InsertMissingArguments" filter | ChangeRecordFieldOptional _ -> - List.mem "ChangeRecordFieldOptional" filter) + List.mem "ChangeRecordFieldOptional" filter + | UnwrapOptionMapRecordField _ -> + List.mem "UnwrapOptionMapRecordField" filter) in match applyActionsToFile path possible_actions with | Ok applied -> From 4a5a8001401040a32295dd8e7bb042f1af126e1c Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 29 Jul 2025 22:42:50 +0200 Subject: [PATCH 40/44] add test files --- ...Actions_AccessRecordFieldOnOption_applied.res | 16 ++++++++++++++++ .../Actions_AccessRecordFieldOnOption.res | 12 ++++++++++++ 2 files changed, 28 insertions(+) create mode 100644 tests/build_tests/actions/expected/Actions_AccessRecordFieldOnOption_applied.res create mode 100644 tests/build_tests/actions/fixtures/Actions_AccessRecordFieldOnOption.res diff --git a/tests/build_tests/actions/expected/Actions_AccessRecordFieldOnOption_applied.res b/tests/build_tests/actions/expected/Actions_AccessRecordFieldOnOption_applied.res new file mode 100644 index 00000000000..11bfbf38f20 --- /dev/null +++ b/tests/build_tests/actions/expected/Actions_AccessRecordFieldOnOption_applied.res @@ -0,0 +1,16 @@ +module X = { + type y = {d: int} + type x = { + a: int, + b: int, + c: option, + } + + let x = {a: 1, b: 2, c: Some({d: 3})} +} + +let f = X.x.c->Option.map(v => v.d) + +/* === AVAILABLE ACTIONS: +- UnwrapOptionMapRecordField(d) - Unwrap the option first before accessing the record field +*/ diff --git a/tests/build_tests/actions/fixtures/Actions_AccessRecordFieldOnOption.res b/tests/build_tests/actions/fixtures/Actions_AccessRecordFieldOnOption.res new file mode 100644 index 00000000000..9d71abf6d5e --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_AccessRecordFieldOnOption.res @@ -0,0 +1,12 @@ +module X = { + type y = {d: int} + type x = { + a: int, + b: int, + c: option, + } + + let x = {a: 1, b: 2, c: Some({d: 3})} +} + +let f = X.x.c.d From 3b44109e3f62b1de251a9141972dce567cf07b0a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 19 Sep 2025 21:24:21 +0200 Subject: [PATCH 41/44] fix syntax error --- compiler/ml/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 43774b4f2c3..af7c2a4942f 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4743,7 +4743,7 @@ let report_error env loc ppf error = fprintf ppf "@,- Missing arguments that must be provided: %s" (missing_required_args |> List.map (fun v -> "~" ^ v) - |> String.concat ", ")); + |> String.concat ", "); fprintf ppf "@,\ From c3c3c9074a8d857ed323498b7ec87a859c0088e0 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 20 Sep 2025 13:55:54 +0200 Subject: [PATCH 42/44] move away from cmt to an explicit sidecar extras file --- .gitignore | 1 + analysis/src/Cmt.ml | 3 +- analysis/src/Resextra.ml | 30 +++++++ analysis/src/Xform.ml | 28 ++++++- compiler/bsc/rescript_compiler_main.ml | 5 +- compiler/core/js_implementation.ml | 12 ++- compiler/ml/{cmt_utils.ml => actions.ml} | 4 +- compiler/ml/cmt_format.ml | 36 ++------- compiler/ml/cmt_format.mli | 2 - compiler/ml/error_message_utils.ml | 22 +++--- compiler/ml/res_extra.ml | 25 ++++++ compiler/ml/res_extra.mli | 7 ++ compiler/ml/typecore.ml | 8 +- compiler/ml/typetexp.ml | 10 +-- rewatch/src/build/clean.rs | 2 +- rewatch/src/build/compile.rs | 14 ++++ .../tests/src/CodeActionExtras.res | 5 ++ .../src/expected/CodeActionExtras.res.txt | 9 +++ .../tests/src/expected/Completion.res.txt | 2 +- tests/build_tests/actions/input.js | 4 +- tools/bin/main.ml | 8 +- tools/src/tools.ml | 78 ++++++++++++------- 22 files changed, 216 insertions(+), 99 deletions(-) create mode 100644 analysis/src/Resextra.ml rename compiler/ml/{cmt_utils.ml => actions.ml} (97%) create mode 100644 compiler/ml/res_extra.ml create mode 100644 compiler/ml/res_extra.mli create mode 100644 tests/analysis_tests/tests/src/CodeActionExtras.res create mode 100644 tests/analysis_tests/tests/src/expected/CodeActionExtras.res.txt diff --git a/.gitignore b/.gitignore index 386c70d047b..272d5fb06cc 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ _build_playground *.cmx *.cmt *.cmti +*.resextra *.cma *.a *.cmxa diff --git a/analysis/src/Cmt.ml b/analysis/src/Cmt.ml index ac1d5ae595f..c89b9e69650 100644 --- a/analysis/src/Cmt.ml +++ b/analysis/src/Cmt.ml @@ -38,7 +38,8 @@ let fullFromUri ~uri = let cmt = getCmtPath ~uri paths in fullForCmt ~moduleName ~package ~uri cmt | None -> - prerr_endline ("can't find module " ^ moduleName); + if not (Uri.isInterface uri) then + prerr_endline ("can't find module " ^ moduleName); None)) let fullsFromModule ~package ~moduleName = diff --git a/analysis/src/Resextra.ml b/analysis/src/Resextra.ml new file mode 100644 index 00000000000..fd9205313cc --- /dev/null +++ b/analysis/src/Resextra.ml @@ -0,0 +1,30 @@ +let extrasPathFromCmtPath cmtPath = + if Filename.check_suffix cmtPath ".cmti" then + Filename.chop_extension cmtPath ^ ".resiextra" + else if Filename.check_suffix cmtPath ".cmt" then + Filename.chop_extension cmtPath ^ ".resextra" + else cmtPath ^ ".resextra" + +let loadActionsFromPackage ~path ~package = + let uri = Uri.fromPath path in + let moduleName = + BuildSystem.namespacedName package.SharedTypes.namespace + (FindFiles.getName path) + in + match Hashtbl.find_opt package.SharedTypes.pathsForModule moduleName with + | None -> None + | Some paths -> + let cmtPath = SharedTypes.getCmtPath ~uri paths in + let extrasPath = extrasPathFromCmtPath cmtPath in + + let tryLoad path = + if Sys.file_exists path then + try + let ic = open_in_bin path in + let v = (input_value ic : Actions.action list) in + close_in ic; + Some v + with _ -> None + else None + in + tryLoad extrasPath diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index ddf783c5590..87be8940576 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -897,6 +897,28 @@ let parseInterface ~filename = let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug = let pos = startPos in let codeActions = ref [] in + let add_actions_from_extras ~path ~pos ~package ~codeActions = + let map_extra_action (a : Actions.action) = + match a.action with + | Actions.RemoveOpen -> + let range = Loc.rangeOfLoc a.loc in + let newText = "" in + Some + (CodeActions.make ~title:a.description ~kind:RefactorRewrite ~uri:path + ~newText ~range) + | _ -> None + in + match Resextra.loadActionsFromPackage ~path ~package with + | None -> () + | Some actions -> + let relevant = + actions + |> List.filter (fun (a : Actions.action) -> Loc.hasPos ~pos a.loc) + in + relevant + |> List.filter_map map_extra_action + |> List.iter (fun ca -> codeActions := ca :: !codeActions) + in match Files.classifySourceFile currentFile with | Res -> let structure, printExpr, printStructureItem, printStandaloneStructure = @@ -920,7 +942,8 @@ let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug = ~pos: (if startPos = endPos then Single startPos else Range (startPos, endPos)) - ~full ~structure ~codeActions ~debug ~currentFile + ~full ~structure ~codeActions ~debug ~currentFile; + add_actions_from_extras ~path ~pos ~package:full.package ~codeActions | None -> () in @@ -929,5 +952,8 @@ let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug = let signature, printSignatureItem = parseInterface ~filename:currentFile in AddDocTemplate.Interface.xform ~pos ~codeActions ~path ~signature ~printSignatureItem; + (match Packages.getPackage ~uri:(Uri.fromPath path) with + | Some package -> add_actions_from_extras ~path ~pos ~package ~codeActions + | None -> ()); !codeActions | Other -> [] diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index dda286923fb..ad056009528 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -437,6 +437,9 @@ let _ : unit = Bs_conditional_initial.setup_env (); Clflags.color := Some Always; + (* Save extras (e.g., actions) once before exit, after all reporting. *) + at_exit (fun () -> Res_extra.save ()); + let flags = "flags" in Ast_config.add_structure flags file_level_flags_handler; Ast_config.add_signature flags file_level_flags_handler; @@ -446,6 +449,4 @@ let _ : unit = exit 2 | x -> Location.report_exception ppf x; - (* Re-save cmt so we can get the possible actions *) - Cmt_format.resave_cmt_with_possible_actions (); exit 2 diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 5f4e4e6c765..f0205ca46d4 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -49,6 +49,8 @@ let after_parsing_sig ppf outputprefix ast = if !Js_config.syntax_only then Warnings.check_fatal () else let modulename = module_of_filename outputprefix in + Res_extra.set_is_interface true; + Res_extra.set_current_outputprefix (Some outputprefix); Lam_compile_env.reset (); let initial_env = Res_compmisc.initial_env ~modulename () in Env.set_unit_name modulename; @@ -65,7 +67,9 @@ let after_parsing_sig ppf outputprefix ast = in Typemod.save_signature modulename tsg outputprefix !Location.input_name initial_env sg; - process_with_gentype (outputprefix ^ ".cmti")) + process_with_gentype (outputprefix ^ ".cmti"); + (* Persist any collected code actions to .resextra sidecar *) + Res_extra.save ()) let interface ~parser ppf ?outputprefix fname = let outputprefix = @@ -130,6 +134,8 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = if !Js_config.syntax_only then Warnings.check_fatal () else let modulename = Ext_filename.module_name outputprefix in + Res_extra.set_is_interface false; + Res_extra.set_current_outputprefix (Some outputprefix); Lam_compile_env.reset (); let env = Res_compmisc.initial_env ~modulename () in Env.set_unit_name modulename; @@ -152,7 +158,9 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = in if not !Js_config.cmj_only then Lam_compile_main.lambda_as_module js_program outputprefix); - process_with_gentype (outputprefix ^ ".cmt")) + process_with_gentype (outputprefix ^ ".cmt"); + (* Persist any collected code actions to .resextra sidecar *) + Res_extra.save ()) let implementation ~parser ppf ?outputprefix fname = let outputprefix = diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/actions.ml similarity index 97% rename from compiler/ml/cmt_utils.ml rename to compiler/ml/actions.ml index f3294fa0d2e..4ce1afb8156 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/actions.ml @@ -60,7 +60,7 @@ type action_type = (* TODO: - Unused var in patterns (and aliases )*) -type cmt_action = {loc: Location.t; action: action_type; description: string} +type action = {loc: Location.t; action: action_type; description: string} let action_to_string = function | ApplyFunction {function_name} -> @@ -117,7 +117,7 @@ let action_to_string = function Printf.sprintf "UnwrapOptionMapRecordField(%s)" (Longident.flatten field_name |> String.concat ".") -let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ()) +let _add_possible_action : (action -> unit) ref = ref (fun _ -> ()) let add_possible_action action = !_add_possible_action action let emit_possible_actions_from_warning loc w = diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index ebb66742a23..8c125127f9f 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -64,7 +64,6 @@ type cmt_infos = { cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; cmt_extra_info: Cmt_utils.cmt_extra_info; - cmt_possible_actions : Cmt_utils.cmt_action list; } type error = @@ -157,13 +156,15 @@ let read_cmi filename = let saved_types = ref [] let value_deps = ref [] let deprecated_used = ref [] -let possible_actions = ref [] let clear () = saved_types := []; value_deps := []; - deprecated_used := []; - possible_actions := [] + deprecated_used := [] + +let clear () = + saved_types := []; + value_deps := [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types @@ -181,10 +182,6 @@ let record_deprecated_used ?deprecated_context ?migration_template ?migration_in :: !deprecated_used let _ = Cmt_utils.record_deprecated_used := record_deprecated_used -let add_possible_action action = - possible_actions := action :: !possible_actions - -let _ = Cmt_utils._add_possible_action := add_possible_action let record_value_dependency vd1 vd2 = if vd1.Types.val_loc <> vd2.Types.val_loc then @@ -195,30 +192,8 @@ let save_cmt _filename _modname _binary_annots _sourcefile _initial_env _cmi = ( #else open Cmi_format -let current_cmt_filename = ref None - -(* TODO: Terrible hack. Figure out way to do this without saving the cmt file twice. - Probably change how/where we save the cmt, and delay it to after writing errors, if possible. -*) -let resave_cmt_with_possible_actions () = - if List.length !possible_actions > 0 then begin - match !current_cmt_filename with - | None -> () - | Some filename -> - let current_cmt = read_cmt filename in - Misc.output_to_bin_file_directly filename - (fun _temp_file_name oc -> - let cmt = { - current_cmt with - cmt_possible_actions = current_cmt.cmt_possible_actions @ !possible_actions; - } in - output_cmt oc cmt) - end; - clear () - let save_cmt filename modname binary_annots sourcefile initial_env cmi = if !Clflags.binary_annotations then begin - current_cmt_filename := Some filename; Misc.output_to_bin_file_directly filename (fun temp_file_name oc -> let this_crc = @@ -243,7 +218,6 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; cmt_extra_info = {deprecated_used = !deprecated_used}; - cmt_possible_actions = !possible_actions; } in output_cmt oc cmt) end; diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 634fdfc1127..66589f088de 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -64,7 +64,6 @@ type cmt_infos = { cmt_interface_digest: Digest.t option; cmt_use_summaries: bool; cmt_extra_info: Cmt_utils.cmt_extra_info; - cmt_possible_actions: Cmt_utils.cmt_action list; } type error = Not_a_typedtree of string @@ -120,7 +119,6 @@ val record_deprecated_used : Location.t -> string -> unit -val resave_cmt_with_possible_actions : unit -> unit (* diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 027fb70ff1b..b9fe4076759 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -389,7 +389,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf \ To fix this, change the highlighted code so it evaluates to a \ @{bool@}." | Some Await, _ -> - Cmt_utils.add_possible_action + Actions.add_possible_action {loc; action = RemoveAwait; description = "Remove await"}; fprintf ppf "\n\n\ @@ -417,7 +417,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | Some ComparisonOperator, _ -> fprintf ppf "\n\n You can only compare things of the same type." | Some ArrayValue, _ -> - Cmt_utils.add_possible_action + Actions.add_possible_action {loc; action = RewriteArrayToTuple; description = "Rewrite to tuple"}; fprintf ppf "\n\n\ @@ -478,7 +478,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf Some record | _ -> None) in - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = RewriteObjectToRecord; @@ -498,7 +498,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | _, Some ({Types.desc = Tconstr (p1, _, _)}, _) when Path.same p1 Predef.path_promise -> (* TODO: This should be aware of if we're in an async context or not? *) - Cmt_utils.add_possible_action + Actions.add_possible_action {loc; action = AddAwait; description = "Await promise"}; fprintf ppf "\n\n - Did you mean to await this promise before using it?\n" | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _}) @@ -507,7 +507,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> match exp.Parsetree.pexp_desc with | Pexp_array items -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = RewriteArrayToTuple; @@ -538,7 +538,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in let print_jsx_msg ?(extra = "") name target_fn = - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = ApplyFunction {function_name = Longident.parse target_fn}; @@ -589,7 +589,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (RecordField {optional = true; field_name; jsx = None}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = ChangeRecordFieldOptional {optional = true}; @@ -632,7 +632,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | ( Some (FunctionArgument {optional = true}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = RewriteArgType {to_type = `Optional}; @@ -696,7 +696,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in match (reprinted, List.mem string_value variant_constructors) with | Some reprinted, true -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = @@ -763,7 +763,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in match reprinted with | Some reprinted -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = @@ -829,7 +829,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf in if can_show_coercion_message && not is_constant then ( - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = diff --git a/compiler/ml/res_extra.ml b/compiler/ml/res_extra.ml new file mode 100644 index 00000000000..89eb4e0ff16 --- /dev/null +++ b/compiler/ml/res_extra.ml @@ -0,0 +1,25 @@ +let current_outputprefix : string option ref = ref None + +let possible_actions : Actions.action list ref = ref [] + +let set_current_outputprefix v = current_outputprefix := v + +let is_interface : bool ref = ref false + +let set_is_interface v = is_interface := v + +let add_possible_action action = possible_actions := action :: !possible_actions + +let () = Actions._add_possible_action := add_possible_action + +let save () = + match !current_outputprefix with + | None -> () + | Some outputprefix -> + let extras_filename = + outputprefix ^ if !is_interface then ".resiextra" else ".resextra" + in + if List.length !possible_actions > 0 then + Misc.output_to_bin_file_directly extras_filename (fun _ oc -> + output_value oc (!possible_actions : Actions.action list)); + possible_actions := [] diff --git a/compiler/ml/res_extra.mli b/compiler/ml/res_extra.mli new file mode 100644 index 00000000000..ff77fbeea22 --- /dev/null +++ b/compiler/ml/res_extra.mli @@ -0,0 +1,7 @@ +val set_current_outputprefix : string option -> unit + +val set_is_interface : bool -> unit + +val add_possible_action : Actions.action -> unit + +val save : unit -> unit diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index af7c2a4942f..82818a476c1 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -701,7 +701,7 @@ let simple_conversions = let print_simple_conversion ~loc ppf (actual, expected) = try let converter = List.assoc (actual, expected) simple_conversions in - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = ApplyFunction {function_name = Longident.parse converter}; @@ -4722,7 +4722,7 @@ let report_error env loc ppf error = if not is_fallback then fprintf ppf "@,"; if List.length missing_required_args > 0 then ( - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = @@ -4734,7 +4734,7 @@ let report_error env loc ppf error = }; description = "Insert missing arguments"; }; - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = PartiallyApplyFunction; @@ -4799,7 +4799,7 @@ let report_error env loc ppf error = match suggestion with | None -> () | Some suggestion_str -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = RewriteIdent {new_ident = Longident.parse suggestion_str}; diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 4e0ac96f73d..f74c9a3a799 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -871,10 +871,10 @@ let report_error env ppf = function if did_spellcheck then choices |> List.iter (fun choice -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; - action = Cmt_utils.RewriteIdent {new_ident = Lident choice}; + action = Actions.RewriteIdent {new_ident = Lident choice}; description = "Change to `" ^ choice ^ "`"; }); (* For cases such as when the user refers to something that's a value with @@ -899,10 +899,10 @@ let report_error env ppf = function in match (as_module, as_module_name) with | Some module_path, Some as_module_name -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; - action = Cmt_utils.RewriteIdentToModule {module_name = as_module_name}; + action = Actions.RewriteIdentToModule {module_name = as_module_name}; description = "Change to `" ^ as_module_name ^ "`"; }; Format.fprintf ppf "@,@[@,@[%s to use the module @{%a@}?@]@]" @@ -949,7 +949,7 @@ let report_error env ppf = function (* modified *) (match from_type with | Some {desc = Tconstr (p, _, _)} when Path.same p Predef.path_option -> - Cmt_utils.add_possible_action + Actions.add_possible_action { loc; action = UnwrapOptionMapRecordField {field_name}; diff --git a/rewatch/src/build/clean.rs b/rewatch/src/build/clean.rs index a66a4607699..b2799f41b8b 100644 --- a/rewatch/src/build/clean.rs +++ b/rewatch/src/build/clean.rs @@ -57,7 +57,7 @@ fn remove_compile_asset(package: &packages::Package, source_file: &Path, extensi pub fn remove_compile_assets(package: &packages::Package, source_file: &Path) { // optimization // only issue cmti if there is an interfacce file - for extension in &["cmj", "cmi", "cmt", "cmti"] { + for extension in &["cmj", "cmi", "cmt", "cmti", "resextra", "resiextra"] { remove_compile_asset(package, source_file, extension); } } diff --git a/rewatch/src/build/compile.rs b/rewatch/src/build/compile.rs index 8048764f094..9d2b3b5baa8 100644 --- a/rewatch/src/build/compile.rs +++ b/rewatch/src/build/compile.rs @@ -734,6 +734,13 @@ fn compile_file( .join(format!("{basename}.cmt")), ocaml_build_path_abs.join(format!("{basename}.cmt")), ); + let _ = std::fs::copy( + package + .get_build_path() + .join(dir) + .join(format!("{basename}.resextra")), + ocaml_build_path_abs.join(format!("{basename}.resextra")), + ); } else { let _ = std::fs::copy( package @@ -746,6 +753,13 @@ fn compile_file( package.get_build_path().join(dir).join(format!("{basename}.cmi")), ocaml_build_path_abs.join(format!("{basename}.cmi")), ); + let _ = std::fs::copy( + package + .get_build_path() + .join(dir) + .join(format!("{basename}.resiextra")), + ocaml_build_path_abs.join(format!("{basename}.resiextra")), + ); } if let SourceType::SourceFile(SourceFile { diff --git a/tests/analysis_tests/tests/src/CodeActionExtras.res b/tests/analysis_tests/tests/src/CodeActionExtras.res new file mode 100644 index 00000000000..0f7d3bdeaa8 --- /dev/null +++ b/tests/analysis_tests/tests/src/CodeActionExtras.res @@ -0,0 +1,5 @@ +@@warning("+33") + +open Belt +// ^xfm + diff --git a/tests/analysis_tests/tests/src/expected/CodeActionExtras.res.txt b/tests/analysis_tests/tests/src/expected/CodeActionExtras.res.txt new file mode 100644 index 00000000000..11d40474216 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/CodeActionExtras.res.txt @@ -0,0 +1,9 @@ +Xform src/CodeActionExtras.res 2:3 +Hit: Remove open + +TextDocumentEdit: CodeActionExtras.res +{"start": {"line": 2, "character": 0}, "end": {"line": 2, "character": 9}} +newText: +<--here + + diff --git a/tests/analysis_tests/tests/src/expected/Completion.res.txt b/tests/analysis_tests/tests/src/expected/Completion.res.txt index df30210ef2b..21cce94bb69 100644 --- a/tests/analysis_tests/tests/src/expected/Completion.res.txt +++ b/tests/analysis_tests/tests/src/expected/Completion.res.txt @@ -2625,7 +2625,7 @@ Path g "kind": 12, "tags": [], "detail": "(result<'a, 'b>, ~message: string=?) => 'a", - "documentation": {"kind": "markdown", "value": "\n `getOrThrow(res, ~message=?)` returns `n` if `res` is `Ok(n)`, otherwise throws an exception with the message provided, or a generic message if no message was provided.\n\n ```res example\n Result.getOrThrow(Result.Ok(42)) == 42\n \n switch Result.getOrThrow(Error(\"Invalid data\")) {\n | exception _ => true\n | _ => false\n } == true\n\n switch Result.getOrThrow(Error(\"Invalid data\"), ~message=\"was Error!\") {\n | exception _ => true // Throws a JsError with the message \"was Error!\"\n | _ => false\n } == true\n ```\n"} + "documentation": {"kind": "markdown", "value": "\n `getOrThrow(res, ~message=?)` returns `n` if `res` is `Ok(n)`, otherwise throws an exception with the message provided, or a generic message if no message was provided.\n\n ```res example\n Result.getOrThrow(Result.Ok(42)) == 42\n \n switch Result.getOrThrow(Error(\"Invalid data\")) {\n | exception _ => assert(true)\n | _ => assert(false)\n }\n\n switch Result.getOrThrow(Error(\"Invalid data\"), ~message=\"was Error!\") {\n | exception _ => assert(true) // Throws a JsError with the message \"was Error!\"\n | _ => assert(false)\n }\n ```\n"} }, { "label": "Result.getOr", "kind": 12, diff --git a/tests/build_tests/actions/input.js b/tests/build_tests/actions/input.js index 51d7e47e6f5..e2b16fe732a 100644 --- a/tests/build_tests/actions/input.js +++ b/tests/build_tests/actions/input.js @@ -33,12 +33,12 @@ let atLeastOneTaskFailed = false; for (const fileName of fixtures) { const fullFilePath = path.join(import.meta.dirname, "fixtures", fileName); - const cmtPath = fullFilePath.replace(".res", ".cmt"); + const extrasPath = fullFilePath.replace(".res", ".resextra"); await bsc([...prefix, "-color", "always", fullFilePath]); const firstLine = (await fs.readFile(fullFilePath, "utf-8")).split("\n")[0] ?? ""; const actionFilter = firstLine.split("actionFilter=")[1]; - const callArgs = [fullFilePath, cmtPath, "--runAll"]; + const callArgs = [fullFilePath, extrasPath, "--runAll"]; if (actionFilter != null) { callArgs.push("--actionFilter", actionFilter); } diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 32c151314f2..f2523b16b97 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -185,9 +185,9 @@ let main () = | _ :: rest -> extract_arg_with_value target_arg rest | [] -> None in - let cmtPath = + let extrasPath = match opts with - | path :: _ when String.ends_with ~suffix:".cmt" path -> Some path + | path :: _ when String.ends_with ~suffix:".resextra" path -> Some path | _ -> None in let actionFilter = @@ -197,8 +197,8 @@ let main () = | None -> None in if run_all_on_file then - Tools.Actions.runActionsOnFile ?actionFilter ?cmtPath file - else Tools.Actions.extractActionsFromFile ?cmtPath file + Tools.Actions.runActionsOnFile ?actionFilter ?extrasPath file + else Tools.Actions.extractActionsFromFile ?extrasPath file | "extract-embedded" :: extPointNames :: filename :: _ -> logAndExit (Ok diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 254e0b91b44..645ca15831f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1317,7 +1317,7 @@ module Actions = struct target_loc actions = let change_record_field_optional_action = actions - |> List.find_map (fun (action : Cmt_utils.cmt_action) -> + |> List.find_map (fun (action : Actions.action) -> match action.action with | ChangeRecordFieldOptional {optional} when target_loc = action.loc -> @@ -1350,7 +1350,7 @@ module Actions = struct (fun mapper str_item -> let remove_rec_flag_action_locs = List.filter_map - (fun (action : Cmt_utils.cmt_action) -> + (fun (action : Actions.action) -> match action.action with | RemoveRecFlag -> Some action.loc | _ -> None) @@ -1358,7 +1358,7 @@ module Actions = struct in let force_open_action_locs = List.filter_map - (fun (action : Cmt_utils.cmt_action) -> + (fun (action : Actions.action) -> match action.action with | ForceOpen -> Some action.loc | _ -> None) @@ -1366,7 +1366,7 @@ module Actions = struct in let assign_to_underscore_action_locs = List.filter_map - (fun (action : Cmt_utils.cmt_action) -> + (fun (action : Actions.action) -> match action.action with | AssignToUnderscore -> Some action.loc | _ -> None) @@ -1415,8 +1415,7 @@ module Actions = struct | Pstr_open _ -> ( let remove_open_action = actions - |> List.find_opt - (fun (action : Cmt_utils.cmt_action) -> + |> List.find_opt (fun (action : Actions.action) -> match action.action with | RemoveOpen -> action.loc = str_item.pstr_loc | _ -> false) @@ -1427,8 +1426,7 @@ module Actions = struct | Pstr_type (_, _type_declarations) -> ( let remove_unused_type_action = actions - |> List.find_opt - (fun (action : Cmt_utils.cmt_action) -> + |> List.find_opt (fun (action : Actions.action) -> match action.action with | RemoveUnusedType -> action.loc = str_item.pstr_loc @@ -1440,7 +1438,7 @@ module Actions = struct | Pstr_module {pmb_loc} -> let remove_unused_module_action_locs = List.filter_map - (fun (action : Cmt_utils.cmt_action) -> + (fun (action : Actions.action) -> match action.action with | RemoveUnusedModule -> Some action.loc | _ -> None) @@ -1463,7 +1461,7 @@ module Actions = struct (fun mapper bindings -> let remove_unused_variables_action_locs = List.filter_map - (fun (action : Cmt_utils.cmt_action) -> + (fun (action : Actions.action) -> match action.action with | RemoveUnusedVariable -> Some action.loc | _ -> None) @@ -1486,7 +1484,7 @@ module Actions = struct | Ppat_var var -> ( let prefix_underscore_action = actions - |> List.find_opt (fun (action : Cmt_utils.cmt_action) -> + |> List.find_opt (fun (action : Actions.action) -> match action.action with | PrefixVariableWithUnderscore -> action.loc = pattern.ppat_loc @@ -1509,7 +1507,7 @@ module Actions = struct |> List.filter_map (fun (case : Parsetree.case) -> let remove_case_action = actions - |> List.find_opt (fun (action : Cmt_utils.cmt_action) -> + |> List.find_opt (fun (action : Actions.action) -> match action.action with | RemoveSwitchCase -> action.loc = case.pc_lhs.ppat_loc @@ -1525,7 +1523,7 @@ module Actions = struct (* TODO: Must account for pipe chains *) let mapped_expr = actions - |> List.find_map (fun (action : Cmt_utils.cmt_action) -> + |> List.find_map (fun (action : Actions.action) -> (* When the loc is the expr itself *) if action.loc = expr.pexp_loc then let expr = Ast_mapper.default_mapper.expr mapper expr in @@ -1819,33 +1817,43 @@ module Actions = struct "error: failed to apply actions to %s because it is not a .res file" path) - let runActionsOnFile ?(actionFilter : string list option) ?cmtPath + let runActionsOnFile ?(actionFilter : string list option) ?extrasPath entryPointFile = let path = match Filename.is_relative entryPointFile with | true -> Unix.realpath entryPointFile | false -> entryPointFile in - let loadedCmt = - match cmtPath with - | None -> Cmt.loadCmtInfosFromPath ~path - | Some path -> Shared.tryReadCmt path + let try_read_resextra path = + if Sys.file_exists path then + try + let ic = open_in_bin path in + let v = (input_value ic : Actions.action list) in + close_in ic; + Some v + with _ -> None + else None in - match loadedCmt with + let loaded_actions = + match extrasPath with + | Some path -> try_read_resextra path + | None -> None + in + match loaded_actions with | None -> Printf.printf "error: failed to run actions on %s because build artifacts could not \ be found. try to build the project" path - | Some {cmt_possible_actions} -> ( + | Some cmt_possible_actions -> ( let possible_actions = match actionFilter with | None -> cmt_possible_actions | Some filter -> cmt_possible_actions - |> List.filter (fun (action : Cmt_utils.cmt_action) -> + |> List.filter (fun (action : Actions.action) -> match action.action with - | Cmt_utils.ApplyFunction _ -> List.mem "ApplyFunction" filter + | Actions.ApplyFunction _ -> List.mem "ApplyFunction" filter | ApplyCoercion _ -> List.mem "ApplyCoercion" filter | RemoveSwitchCase -> List.mem "RemoveSwitchCase" filter | RemoveOpen -> List.mem "RemoveOpen" filter @@ -1887,27 +1895,37 @@ module Actions = struct print_endline applied; print_endline "/* === AVAILABLE ACTIONS:"; cmt_possible_actions - |> List.iter (fun (action : Cmt_utils.cmt_action) -> + |> List.iter (fun (action : Actions.action) -> Printf.printf "- %s - %s\n" - (Cmt_utils.action_to_string action.action) + (Actions.action_to_string action.action) action.description); print_endline "*/" | Error e -> print_endline e; exit 1) - let extractActionsFromFile ?cmtPath entryPointFile = + let extractActionsFromFile ?extrasPath entryPointFile = let path = match Filename.is_relative entryPointFile with | true -> Unix.realpath entryPointFile | false -> entryPointFile in - let loadedCmt = - match cmtPath with - | None -> Cmt.loadCmtInfosFromPath ~path - | Some path -> Shared.tryReadCmt path + let try_read_resextra path = + if Sys.file_exists path then + try + let ic = open_in_bin path in + let v = (input_value ic : Actions.action list) in + close_in ic; + Some v + with _ -> None + else None + in + let loaded_actions = + match extrasPath with + | Some path -> try_read_resextra path + | None -> None in - match loadedCmt with + match loaded_actions with | None -> Printf.printf "error: failed to extract actions for %s because build artifacts could \ From 6997605e1a1594dc24368fb22d287dbc6e10a36c Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 20 Sep 2025 14:03:34 +0200 Subject: [PATCH 43/44] test output --- tests/analysis_tests/tests/src/expected/Completion.res.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/analysis_tests/tests/src/expected/Completion.res.txt b/tests/analysis_tests/tests/src/expected/Completion.res.txt index 21cce94bb69..df30210ef2b 100644 --- a/tests/analysis_tests/tests/src/expected/Completion.res.txt +++ b/tests/analysis_tests/tests/src/expected/Completion.res.txt @@ -2625,7 +2625,7 @@ Path g "kind": 12, "tags": [], "detail": "(result<'a, 'b>, ~message: string=?) => 'a", - "documentation": {"kind": "markdown", "value": "\n `getOrThrow(res, ~message=?)` returns `n` if `res` is `Ok(n)`, otherwise throws an exception with the message provided, or a generic message if no message was provided.\n\n ```res example\n Result.getOrThrow(Result.Ok(42)) == 42\n \n switch Result.getOrThrow(Error(\"Invalid data\")) {\n | exception _ => assert(true)\n | _ => assert(false)\n }\n\n switch Result.getOrThrow(Error(\"Invalid data\"), ~message=\"was Error!\") {\n | exception _ => assert(true) // Throws a JsError with the message \"was Error!\"\n | _ => assert(false)\n }\n ```\n"} + "documentation": {"kind": "markdown", "value": "\n `getOrThrow(res, ~message=?)` returns `n` if `res` is `Ok(n)`, otherwise throws an exception with the message provided, or a generic message if no message was provided.\n\n ```res example\n Result.getOrThrow(Result.Ok(42)) == 42\n \n switch Result.getOrThrow(Error(\"Invalid data\")) {\n | exception _ => true\n | _ => false\n } == true\n\n switch Result.getOrThrow(Error(\"Invalid data\"), ~message=\"was Error!\") {\n | exception _ => true // Throws a JsError with the message \"was Error!\"\n | _ => false\n } == true\n ```\n"} }, { "label": "Result.getOr", "kind": 12, From 4c88d7eca02dc7d44fb4a3a60e459c9c4a028bf7 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 7 Oct 2025 08:37:13 +0200 Subject: [PATCH 44/44] fixes after merge --- compiler/ml/cmt_format.ml | 4 ---- compiler/ml/cmt_utils.ml | 31 +++++++++++++++++++++++++++++++ compiler/ml/typecore.ml | 2 +- 3 files changed, 32 insertions(+), 5 deletions(-) create mode 100644 compiler/ml/cmt_utils.ml diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index 8c125127f9f..ff30fc00435 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -162,10 +162,6 @@ let clear () = value_deps := []; deprecated_used := [] -let clear () = - saved_types := []; - value_deps := [] - let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml new file mode 100644 index 00000000000..3e08cd93b47 --- /dev/null +++ b/compiler/ml/cmt_utils.ml @@ -0,0 +1,31 @@ +type deprecated_used_context = FunctionCall | Reference + +type deprecated_used = { + source_loc: Location.t; + deprecated_text: string; + migration_template: Parsetree.expression option; + migration_in_pipe_chain_template: Parsetree.expression option; + context: deprecated_used_context option; +} + +type cmt_extra_info = {deprecated_used: deprecated_used list} + +let record_deprecated_used : + (?deprecated_context:deprecated_used_context -> + ?migration_template:Parsetree.expression -> + ?migration_in_pipe_chain_template:Parsetree.expression -> + Location.t -> + string -> + unit) + ref = + ref + (fun + ?deprecated_context + ?migration_template + ?migration_in_pipe_chain_template + _ + _ + -> + ignore deprecated_context; + ignore migration_template; + ignore migration_in_pipe_chain_template) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 82818a476c1..004ea07568b 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3722,7 +3722,7 @@ and type_application ~context total_app env funct (sargs : sargs) : Some (fun () -> option_none (instance env ty) Location.none) )) else (sargs, (l, ty, lv) :: omitted, None) | Some (l', sarg0, sargs) -> - if (not optional) && is_optional_loc l' then + if (not optional) && is_optional l' then (* TODO(actions) Add ? to make argument optional *) Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l));